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/utilities/README | 3 + pkg/utilities/Revisions | 178 + pkg/utilities/bases.cl | 87 + pkg/utilities/curfit.gx | 216 ++ pkg/utilities/curfit.h | 19 + pkg/utilities/curfit.par | 12 + pkg/utilities/curfit.x | 404 +++ pkg/utilities/decod_tablst.x | 104 + pkg/utilities/detab.par | 2 + pkg/utilities/doc/bases.hlp | 43 + pkg/utilities/doc/curfit.hlp | 168 + pkg/utilities/doc/detab.hlp | 28 + pkg/utilities/doc/entab.hlp | 30 + pkg/utilities/doc/lcase.hlp | 32 + pkg/utilities/doc/polyfit.hlp | 91 + pkg/utilities/doc/split.hlp | 59 + pkg/utilities/doc/surfit.hlp | 257 ++ pkg/utilities/doc/translit.hlp | 49 + pkg/utilities/doc/ucase.hlp | 32 + pkg/utilities/doc/urand.hlp | 41 + pkg/utilities/entab.par | 2 + pkg/utilities/lcase.par | 1 + pkg/utilities/mkpkg | 51 + pkg/utilities/nttools/README | 32 + pkg/utilities/nttools/atools/mkpkg | 10 + pkg/utilities/nttools/atools/taextract.x | 214 ++ pkg/utilities/nttools/atools/taincr.x | 55 + pkg/utilities/nttools/atools/tainsert.x | 260 ++ pkg/utilities/nttools/copyone/addslash.x | 32 + pkg/utilities/nttools/copyone/datatype.x | 79 + pkg/utilities/nttools/copyone/filetype.h | 5 + pkg/utilities/nttools/copyone/filetype.x | 28 + pkg/utilities/nttools/copyone/filetype.x.OLD | 61 + pkg/utilities/nttools/copyone/getimghdr.x | 35 + pkg/utilities/nttools/copyone/gettabdat.x | 111 + pkg/utilities/nttools/copyone/gettabhdr.x | 55 + pkg/utilities/nttools/copyone/isdouble.x | 37 + pkg/utilities/nttools/copyone/keypar.x | 109 + pkg/utilities/nttools/copyone/keytab.x | 113 + pkg/utilities/nttools/copyone/mkpkg | 29 + pkg/utilities/nttools/copyone/parkey.x | 71 + pkg/utilities/nttools/copyone/partab.x | 51 + pkg/utilities/nttools/copyone/putimghdr.x | 118 + pkg/utilities/nttools/copyone/puttabdat.x | 106 + pkg/utilities/nttools/copyone/puttabhdr.x | 104 + pkg/utilities/nttools/copyone/tabaccess.x | 19 + pkg/utilities/nttools/copyone/tabhdrtyp.x | 34 + pkg/utilities/nttools/copyone/tabkey.x | 94 + pkg/utilities/nttools/copyone/tabpar.x | 54 + pkg/utilities/nttools/doc/axispar.hlp | 138 + pkg/utilities/nttools/doc/dvpar.hlp | 68 + pkg/utilities/nttools/doc/gtedit.hlp | 116 + pkg/utilities/nttools/doc/gtpar.hlp | 117 + pkg/utilities/nttools/doc/imtab.hlp | 169 + pkg/utilities/nttools/doc/keypar.hlp | 83 + pkg/utilities/nttools/doc/keyselect.hlp | 246 ++ pkg/utilities/nttools/doc/keytab.hlp | 61 + pkg/utilities/nttools/doc/parkey.hlp | 73 + pkg/utilities/nttools/doc/partab.hlp | 62 + pkg/utilities/nttools/doc/pltpar.hlp | 160 + pkg/utilities/nttools/doc/tabim.hlp | 98 + pkg/utilities/nttools/doc/tabkey.hlp | 68 + pkg/utilities/nttools/doc/tabpar.hlp | 95 + pkg/utilities/nttools/doc/taextract.hlp | 109 + pkg/utilities/nttools/doc/tainsert.hlp | 132 + pkg/utilities/nttools/doc/tcalc.hlp | 153 + pkg/utilities/nttools/doc/tchcol.hlp | 80 + pkg/utilities/nttools/doc/tcheck.hlp | 137 + pkg/utilities/nttools/doc/tchsize.hlp | 158 + pkg/utilities/nttools/doc/tcopy.hlp | 113 + pkg/utilities/nttools/doc/tcreate.hlp | 378 +++ pkg/utilities/nttools/doc/tdelete.hlp | 74 + pkg/utilities/nttools/doc/tdiffer.hlp | 65 + pkg/utilities/nttools/doc/tdump.hlp | 150 + pkg/utilities/nttools/doc/tedit.hlp | 295 ++ pkg/utilities/nttools/doc/texpand.hlp | 159 + pkg/utilities/nttools/doc/thedit.hlp | 208 ++ pkg/utilities/nttools/doc/thistogram.hlp | 152 + pkg/utilities/nttools/doc/thselect.hlp | 90 + pkg/utilities/nttools/doc/tinfo.hlp | 125 + pkg/utilities/nttools/doc/tintegrate.hlp | 97 + pkg/utilities/nttools/doc/tjoin.hlp | 120 + pkg/utilities/nttools/doc/tlcol.hlp | 75 + pkg/utilities/nttools/doc/tlinear.hlp | 127 + pkg/utilities/nttools/doc/tmatch.hlp | 225 ++ pkg/utilities/nttools/doc/tmerge.hlp | 231 ++ pkg/utilities/nttools/doc/tprint.hlp | 276 ++ pkg/utilities/nttools/doc/tproduct.hlp | 48 + pkg/utilities/nttools/doc/tproject.hlp | 79 + pkg/utilities/nttools/doc/tquery.hlp | 115 + pkg/utilities/nttools/doc/tread.hlp | 159 + pkg/utilities/nttools/doc/trebin.hlp | 257 ++ pkg/utilities/nttools/doc/tselect.hlp | 147 + pkg/utilities/nttools/doc/tsort.hlp | 84 + pkg/utilities/nttools/doc/tstat.hlp | 225 ++ pkg/utilities/nttools/doc/ttranspose.hlp | 139 + pkg/utilities/nttools/doc/tunits.hlp | 143 + pkg/utilities/nttools/doc/tupar.hlp | 365 +++ pkg/utilities/nttools/doc/wcspars.hlp | 184 ++ pkg/utilities/nttools/doc/wlpars.hlp | 440 +++ pkg/utilities/nttools/gtedit.par | 11 + pkg/utilities/nttools/gtedit/gtdelete.x | 360 ++ pkg/utilities/nttools/gtedit/gtdodel.x | 41 + pkg/utilities/nttools/gtedit/gtedit.key | 25 + pkg/utilities/nttools/gtedit/gthinfo.x | 69 + pkg/utilities/nttools/gtedit/gtplot.x | 501 +++ pkg/utilities/nttools/gtedit/gtrdxycol.x | 50 + pkg/utilities/nttools/gtedit/gtupdate.x | 36 + pkg/utilities/nttools/gtedit/gtwrdata.x | 90 + pkg/utilities/nttools/gtedit/gtwrhead.x | 47 + pkg/utilities/nttools/gtedit/mkpkg | 19 + pkg/utilities/nttools/gtedit/t_gtedit.x | 184 ++ pkg/utilities/nttools/gtpar.par | 27 + pkg/utilities/nttools/imtab.par | 8 + pkg/utilities/nttools/imtab/imtab.h | 4 + pkg/utilities/nttools/imtab/imtab.x | 476 +++ pkg/utilities/nttools/imtab/itbwcs.x | 129 + pkg/utilities/nttools/imtab/mkpkg | 13 + pkg/utilities/nttools/imtab/tabim.x | 176 + pkg/utilities/nttools/keypar.par | 6 + pkg/utilities/nttools/keyselect.par | 6 + pkg/utilities/nttools/keyselect/expr.x | 193 ++ pkg/utilities/nttools/keyselect/keyselect.com | 9 + pkg/utilities/nttools/keyselect/keyselect.h | 17 + pkg/utilities/nttools/keyselect/keyselect.x | 122 + pkg/utilities/nttools/keyselect/keyword.x | 253 ++ pkg/utilities/nttools/keyselect/list.x | 215 ++ pkg/utilities/nttools/keyselect/mkpkg | 15 + pkg/utilities/nttools/keyselect/tab.x | 353 ++ pkg/utilities/nttools/keytab.par | 7 + pkg/utilities/nttools/lib/allcols.x | 29 + pkg/utilities/nttools/lib/allrows.x | 29 + pkg/utilities/nttools/lib/compare.com | 7 + pkg/utilities/nttools/lib/compare.x | 258 ++ pkg/utilities/nttools/lib/ftnexpr.x | 127 + pkg/utilities/nttools/lib/gettabcol.x | 67 + pkg/utilities/nttools/lib/inquotes.x | 121 + pkg/utilities/nttools/lib/invert.x | 55 + pkg/utilities/nttools/lib/mjd.x | 94 + pkg/utilities/nttools/lib/mkpkg | 33 + pkg/utilities/nttools/lib/movenulls.x | 35 + pkg/utilities/nttools/lib/msort.x | 113 + pkg/utilities/nttools/lib/newcolnam.x | 97 + pkg/utilities/nttools/lib/reloperr.h | 3 + pkg/utilities/nttools/lib/reorder.x | 60 + pkg/utilities/nttools/lib/select.x | 99 + pkg/utilities/nttools/lib/tabvar.x | 118 + pkg/utilities/nttools/lib/tbfile.x | 85 + pkg/utilities/nttools/lib/tbleval.x | 159 + pkg/utilities/nttools/lib/tbljoin.x | 168 + pkg/utilities/nttools/lib/tblmerge.x | 162 + pkg/utilities/nttools/lib/tblsearch.x | 104 + pkg/utilities/nttools/lib/tblsort.x | 39 + pkg/utilities/nttools/lib/tblsort1.x | 157 + pkg/utilities/nttools/lib/tblsortm.x | 168 + pkg/utilities/nttools/lib/tblterm.com | 7 + pkg/utilities/nttools/lib/tblterm.x | 256 ++ pkg/utilities/nttools/lib/tctexp.x | 442 +++ pkg/utilities/nttools/lib/tldtype.x | 70 + pkg/utilities/nttools/lib/tuopen.x | 197 ++ pkg/utilities/nttools/lib/unique.x | 64 + pkg/utilities/nttools/mkpkg | 80 + pkg/utilities/nttools/nttools.cl | 60 + pkg/utilities/nttools/nttools.hd | 91 + pkg/utilities/nttools/nttools.hlp | 244 ++ pkg/utilities/nttools/nttools.men | 61 + pkg/utilities/nttools/nttools.par | 3 + pkg/utilities/nttools/parkey.par | 5 + pkg/utilities/nttools/partab.par | 5 + pkg/utilities/nttools/stxtools/changt.x | 98 + pkg/utilities/nttools/stxtools/checkdim.x | 24 + pkg/utilities/nttools/stxtools/cif.h | 95 + pkg/utilities/nttools/stxtools/cif.x | 806 +++++ pkg/utilities/nttools/stxtools/clgnone.x | 37 + pkg/utilities/nttools/stxtools/copyimg.x | 78 + pkg/utilities/nttools/stxtools/doc/wcs.doc | 177 + pkg/utilities/nttools/stxtools/errxit.x | 30 + pkg/utilities/nttools/stxtools/fbuild.x | 97 + pkg/utilities/nttools/stxtools/fparse.x | 170 + pkg/utilities/nttools/stxtools/grmimy.x | 68 + pkg/utilities/nttools/stxtools/isblank.x | 18 + pkg/utilities/nttools/stxtools/lubksb.f | 50 + pkg/utilities/nttools/stxtools/lubksd.f | 53 + pkg/utilities/nttools/stxtools/ludcmd.x | 99 + pkg/utilities/nttools/stxtools/ludcmp.x | 87 + pkg/utilities/nttools/stxtools/mkpkg | 54 + pkg/utilities/nttools/stxtools/od/mkpkg | 15 + pkg/utilities/nttools/stxtools/od/od.h | 32 + pkg/utilities/nttools/stxtools/od/odget.x | 56 + pkg/utilities/nttools/stxtools/od/odmap.x | 250 ++ pkg/utilities/nttools/stxtools/od/odopep.x | 56 + pkg/utilities/nttools/stxtools/od/odpare.x | 84 + pkg/utilities/nttools/stxtools/od/odput.x | 50 + pkg/utilities/nttools/stxtools/od/odsetn.x | 29 + pkg/utilities/nttools/stxtools/od/odunmp.x | 44 + pkg/utilities/nttools/stxtools/od/odwcsn.x | 39 + pkg/utilities/nttools/stxtools/postexit.x | 52 + pkg/utilities/nttools/stxtools/savgol.x | 140 + pkg/utilities/nttools/stxtools/sbuf.h | 15 + pkg/utilities/nttools/stxtools/sbuf.x | 110 + pkg/utilities/nttools/stxtools/sgcone.x | 94 + pkg/utilities/nttools/stxtools/similar.x | 127 + pkg/utilities/nttools/stxtools/sp_util/mkpkg | 16 + pkg/utilities/nttools/stxtools/sp_util/spchag.x | 64 + pkg/utilities/nttools/stxtools/sp_util/spdise.x | 44 + pkg/utilities/nttools/stxtools/sp_util/spmapt.x | 94 + pkg/utilities/nttools/stxtools/sp_util/sprote.x | 49 + pkg/utilities/nttools/stxtools/sp_util/spstry.x | 24 + pkg/utilities/nttools/stxtools/sp_util/sptras.x | 35 + pkg/utilities/nttools/stxtools/sp_util/spw2ld.x | 50 + pkg/utilities/nttools/stxtools/sp_util/spwcss.x | 90 + pkg/utilities/nttools/stxtools/strjust.x | 31 + pkg/utilities/nttools/stxtools/stxgetcoord.x | 182 ++ pkg/utilities/nttools/stxtools/template.h | 21 + pkg/utilities/nttools/stxtools/tpbreak.x | 80 + pkg/utilities/nttools/stxtools/tpclose.x | 21 + pkg/utilities/nttools/stxtools/tpcount.x | 134 + pkg/utilities/nttools/stxtools/tpfetch.x | 43 + pkg/utilities/nttools/stxtools/tpgroup.x | 87 + pkg/utilities/nttools/stxtools/tpimtype.x | 116 + pkg/utilities/nttools/stxtools/tpopen.x | 38 + pkg/utilities/nttools/stxtools/tpparse.x | 108 + pkg/utilities/nttools/stxtools/vex.com | 11 + pkg/utilities/nttools/stxtools/vex.h | 107 + pkg/utilities/nttools/stxtools/vexcompile.x | 973 ++++++ pkg/utilities/nttools/stxtools/vexcompile.y | 616 ++++ pkg/utilities/nttools/stxtools/vexeval.x | 228 ++ pkg/utilities/nttools/stxtools/vexfree.x | 22 + pkg/utilities/nttools/stxtools/vexfunc.x | 2011 ++++++++++++ pkg/utilities/nttools/stxtools/vexstack.x | 585 ++++ pkg/utilities/nttools/stxtools/wcslab/mkpkg | 17 + pkg/utilities/nttools/stxtools/wcslab/mkpkg.ori | 18 + pkg/utilities/nttools/stxtools/wcslab/psiescape.h | 80 + pkg/utilities/nttools/stxtools/wcslab/t_wcslab.x | 136 + pkg/utilities/nttools/stxtools/wcslab/wcs_desc.h | 219 ++ pkg/utilities/nttools/stxtools/wcslab/wcslab.h | 98 + pkg/utilities/nttools/stxtools/wcslab/wcslab.x | 935 ++++++ pkg/utilities/nttools/stxtools/wcslab/wlgrid.x | 448 +++ pkg/utilities/nttools/stxtools/wcslab/wllabel.x | 1100 +++++++ .../nttools/stxtools/wcslab/wllabel.x.ori | 1077 ++++++ pkg/utilities/nttools/stxtools/wcslab/wlsetup.x | 1000 ++++++ pkg/utilities/nttools/stxtools/wcslab/wlutil.x | 390 +++ pkg/utilities/nttools/stxtools/wcslab/wlwcslab.x | 181 ++ pkg/utilities/nttools/stxtools/word.x | 229 ++ pkg/utilities/nttools/stxtools/xtwcs.x | 1286 ++++++++ pkg/utilities/nttools/tabim.par | 11 + pkg/utilities/nttools/tabkey.par | 7 + pkg/utilities/nttools/tabpar.par | 7 + pkg/utilities/nttools/tabvar.com | 9 + pkg/utilities/nttools/taextract.par | 10 + pkg/utilities/nttools/tainsert.par | 11 + pkg/utilities/nttools/tcalc.par | 7 + pkg/utilities/nttools/tcalc/mkpkg | 11 + pkg/utilities/nttools/tcalc/tcalc.x | 132 + pkg/utilities/nttools/tchcol.par | 7 + pkg/utilities/nttools/tchcol/mkpkg | 20 + pkg/utilities/nttools/tchcol/tchcol.x | 162 + pkg/utilities/nttools/tcheck.par | 3 + pkg/utilities/nttools/tcheck/cmdsplit.x | 57 + pkg/utilities/nttools/tcheck/mkpkg | 13 + pkg/utilities/nttools/tcheck/tcheck.h | 4 + pkg/utilities/nttools/tcheck/tcheck.x | 91 + pkg/utilities/nttools/tcheck/wrtcheck.x | 61 + pkg/utilities/nttools/tchsize.par | 8 + pkg/utilities/nttools/tchsize/mkpkg | 11 + pkg/utilities/nttools/tchsize/tchsize.x | 173 + pkg/utilities/nttools/tcopy.par | 4 + pkg/utilities/nttools/tcopy/iswholetab.x | 24 + pkg/utilities/nttools/tcopy/mkpkg | 13 + pkg/utilities/nttools/tcopy/tcopy.x | 283 ++ pkg/utilities/nttools/tcopy/tdelete.x | 126 + pkg/utilities/nttools/tcopy/trename.x | 185 ++ pkg/utilities/nttools/tcreate.par | 12 + pkg/utilities/nttools/tcreate/gnextl.x | 152 + pkg/utilities/nttools/tcreate/mkpkg | 12 + pkg/utilities/nttools/tcreate/tcreate.x | 958 ++++++ pkg/utilities/nttools/tdelete.par | 5 + pkg/utilities/nttools/tdiffer.par | 6 + pkg/utilities/nttools/tdiffer/mkpkg | 12 + pkg/utilities/nttools/tdiffer/tbldiff.x | 99 + pkg/utilities/nttools/tdiffer/tdiffer.x | 92 + pkg/utilities/nttools/tdump.par | 8 + pkg/utilities/nttools/tedit.par | 6 + pkg/utilities/nttools/tedit/bell.x | 19 + pkg/utilities/nttools/tedit/command.com | 6 + pkg/utilities/nttools/tedit/command.h | 21 + pkg/utilities/nttools/tedit/command.x | 1458 +++++++++ pkg/utilities/nttools/tedit/display/curses.h | 86 + pkg/utilities/nttools/tedit/display/curses/README | 387 +++ pkg/utilities/nttools/tedit/display/curses/addch.x | 30 + .../nttools/tedit/display/curses/addstr.x | 157 + .../nttools/tedit/display/curses/bindstruct.x | 35 + pkg/utilities/nttools/tedit/display/curses/box.x | 56 + pkg/utilities/nttools/tedit/display/curses/clear.x | 35 + .../nttools/tedit/display/curses/clearok.x | 21 + .../nttools/tedit/display/curses/clrtobot.x | 56 + .../nttools/tedit/display/curses/clrtoeol.x | 45 + pkg/utilities/nttools/tedit/display/curses/delch.x | 41 + .../nttools/tedit/display/curses/deleteln.x | 41 + .../nttools/tedit/display/curses/delwin.x | 42 + pkg/utilities/nttools/tedit/display/curses/echo.x | 23 + .../nttools/tedit/display/curses/endwin.x | 34 + pkg/utilities/nttools/tedit/display/curses/erase.x | 37 + .../nttools/tedit/display/curses/freescreen.x | 13 + pkg/utilities/nttools/tedit/display/curses/getch.x | 53 + .../nttools/tedit/display/curses/getscreen.x | 48 + .../nttools/tedit/display/curses/getstr.x | 317 ++ .../nttools/tedit/display/curses/getstruct.x | 27 + pkg/utilities/nttools/tedit/display/curses/getyx.x | 22 + .../nttools/tedit/display/curses/hidewin.x | 40 + pkg/utilities/nttools/tedit/display/curses/inch.x | 49 + .../nttools/tedit/display/curses/initscr.x | 33 + pkg/utilities/nttools/tedit/display/curses/insch.x | 51 + .../nttools/tedit/display/curses/insertln.x | 41 + .../nttools/tedit/display/curses/leaveok.x | 21 + pkg/utilities/nttools/tedit/display/curses/mkpkg | 49 + pkg/utilities/nttools/tedit/display/curses/move.x | 39 + pkg/utilities/nttools/tedit/display/curses/mvwin.x | 63 + .../nttools/tedit/display/curses/mvword.x | 56 + .../nttools/tedit/display/curses/newwin.x | 83 + pkg/utilities/nttools/tedit/display/curses/omkpkg | 65 + .../nttools/tedit/display/curses/putscreen.x | 84 + .../nttools/tedit/display/curses/refresh.x | 42 + .../nttools/tedit/display/curses/savewin.x | 23 + .../nttools/tedit/display/curses/scrollok.x | 21 + .../nttools/tedit/display/curses/showwin.x | 39 + .../nttools/tedit/display/curses/standout.x | 48 + .../nttools/tedit/display/curses/wdimen.x | 45 + .../nttools/tedit/display/curses/window.com | 7 + .../nttools/tedit/display/curses/window.h | 28 + .../nttools/tedit/display/curses/winstat.x | 51 + .../nttools/tedit/display/curses/wslide.x | 91 + pkg/utilities/nttools/tedit/display/forms/README | 115 + .../nttools/tedit/display/forms/fmbegin.x | 20 + .../nttools/tedit/display/forms/fmcheck.x | 98 + pkg/utilities/nttools/tedit/display/forms/fmend.x | 12 + .../nttools/tedit/display/forms/fmgetform.x | 89 + pkg/utilities/nttools/tedit/display/forms/fmhelp.x | 132 + .../nttools/tedit/display/forms/fmmkform.x | 82 + .../nttools/tedit/display/forms/fmprompt.x | 70 + .../nttools/tedit/display/forms/fmredraw.x | 69 + pkg/utilities/nttools/tedit/display/forms/formfn.h | 20 + pkg/utilities/nttools/tedit/display/forms/formfn.x | 278 ++ .../nttools/tedit/display/forms/forms.com | 5 + pkg/utilities/nttools/tedit/display/forms/linefn.h | 8 + pkg/utilities/nttools/tedit/display/forms/linefn.x | 134 + pkg/utilities/nttools/tedit/display/forms/mkpkg | 19 + .../nttools/tedit/display/forms/promptfn.h | 7 + .../nttools/tedit/display/forms/promptfn.x | 134 + pkg/utilities/nttools/tedit/display/mkpkg | 14 + pkg/utilities/nttools/tedit/display/screen/README | 211 ++ .../nttools/tedit/display/screen/kbegin.x | 40 + .../nttools/tedit/display/screen/kcompile.x | 148 + .../nttools/tedit/display/screen/kconvert.x | 61 + .../nttools/tedit/display/screen/kdoline.x | 96 + pkg/utilities/nttools/tedit/display/screen/kend.x | 49 + pkg/utilities/nttools/tedit/display/screen/kget.x | 96 + pkg/utilities/nttools/tedit/display/screen/khelp.x | 61 + .../nttools/tedit/display/screen/kpushbk.x | 11 + pkg/utilities/nttools/tedit/display/screen/mkpkg | 32 + .../nttools/tedit/display/screen/psbeep.x | 9 + .../nttools/tedit/display/screen/psbegin.x | 59 + pkg/utilities/nttools/tedit/display/screen/psend.x | 48 + .../nttools/tedit/display/screen/psfill.x | 135 + .../nttools/tedit/display/screen/psheight.x | 12 + .../nttools/tedit/display/screen/psintersect.x | 27 + .../nttools/tedit/display/screen/psscreen.x | 14 + .../nttools/tedit/display/screen/pssendcap.x | 74 + .../nttools/tedit/display/screen/pssetcur.x | 117 + .../nttools/tedit/display/screen/psslide.x | 182 ++ .../nttools/tedit/display/screen/pssynch.x | 12 + .../nttools/tedit/display/screen/pswidth.x | 12 + .../nttools/tedit/display/screen/pswrite.x | 79 + .../nttools/tedit/display/screen/pswrtcells.x | 114 + .../nttools/tedit/display/screen/screen.com | 18 + pkg/utilities/nttools/tedit/edit.x | 70 + pkg/utilities/nttools/tedit/field.h | 23 + pkg/utilities/nttools/tedit/field.x | 749 +++++ pkg/utilities/nttools/tedit/mkpkg | 27 + pkg/utilities/nttools/tedit/paste.h | 6 + pkg/utilities/nttools/tedit/paste.x | 142 + pkg/utilities/nttools/tedit/prompt.x | 225 ++ pkg/utilities/nttools/tedit/screen.h | 18 + pkg/utilities/nttools/tedit/screen.x | 699 ++++ pkg/utilities/nttools/tedit/substitute.x | 372 +++ pkg/utilities/nttools/tedit/table.h | 22 + pkg/utilities/nttools/tedit/table.x | 312 ++ pkg/utilities/nttools/tedit/tedit.key | 23 + pkg/utilities/nttools/tedit/tedit.x | 33 + pkg/utilities/nttools/tedit/tread.x | 31 + pkg/utilities/nttools/tedit/window.com | 8 + pkg/utilities/nttools/tedit/window.x | 246 ++ pkg/utilities/nttools/texpand.par | 6 + pkg/utilities/nttools/texpand/dbgrules.x | 164 + pkg/utilities/nttools/texpand/lexer.x | 114 + pkg/utilities/nttools/texpand/lexoper.h | 29 + pkg/utilities/nttools/texpand/mkpkg | 21 + pkg/utilities/nttools/texpand/mkrules.x | 48 + pkg/utilities/nttools/texpand/movelem.x | 113 + pkg/utilities/nttools/texpand/movtbrow.x | 43 + pkg/utilities/nttools/texpand/parser.com | 6 + pkg/utilities/nttools/texpand/parser.x | 283 ++ pkg/utilities/nttools/texpand/pushstack.x | 226 ++ pkg/utilities/nttools/texpand/span.x | 97 + pkg/utilities/nttools/texpand/texpand.x | 94 + pkg/utilities/nttools/texpand/userules.x | 286 ++ pkg/utilities/nttools/texpand/x_texpand.x | 3 + pkg/utilities/nttools/thedit.par | 7 + pkg/utilities/nttools/thedit/mkpkg | 13 + pkg/utilities/nttools/thedit/t_thedit.x | 833 +++++ pkg/utilities/nttools/thedit/t_thselect.x | 150 + pkg/utilities/nttools/thedit/tkw.x | 405 +++ pkg/utilities/nttools/thistogram.par | 14 + pkg/utilities/nttools/threed/doc/selectors.hlp | 91 + pkg/utilities/nttools/threed/doc/tiimage.hlp | 108 + pkg/utilities/nttools/threed/doc/titable.hlp | 100 + pkg/utilities/nttools/threed/doc/tscopy.hlp | 94 + pkg/utilities/nttools/threed/doc/tximage.hlp | 85 + pkg/utilities/nttools/threed/doc/txtable.hlp | 89 + pkg/utilities/nttools/threed/mkpkg | 25 + pkg/utilities/nttools/threed/tblerr.h | 27 + pkg/utilities/nttools/threed/tbtables.h | 123 + pkg/utilities/nttools/threed/tiimage.par | 7 + pkg/utilities/nttools/threed/tiimage/design1.txt | 353 ++ pkg/utilities/nttools/threed/tiimage/generic/mkpkg | 14 + .../nttools/threed/tiimage/generic/tmcp1d.x | 54 + .../nttools/threed/tiimage/generic/tmcp1i.x | 54 + .../nttools/threed/tiimage/generic/tmcp1r.x | 54 + .../nttools/threed/tiimage/generic/tmcp1s.x | 54 + pkg/utilities/nttools/threed/tiimage/list.tex | 789 +++++ pkg/utilities/nttools/threed/tiimage/list.toc | 10 + pkg/utilities/nttools/threed/tiimage/loc.txt | 12 + pkg/utilities/nttools/threed/tiimage/mkpkg | 29 + pkg/utilities/nttools/threed/tiimage/tiimage.h | 9 + pkg/utilities/nttools/threed/tiimage/tiimage.x | 147 + pkg/utilities/nttools/threed/tiimage/tmcopy.x | 67 + pkg/utilities/nttools/threed/tiimage/tmcp1.gx | 54 + pkg/utilities/nttools/threed/tiimage/tmhc.x | 57 + pkg/utilities/nttools/threed/tiimage/tmheader.x | 60 + pkg/utilities/nttools/threed/tiimage/tmloop.x | 104 + pkg/utilities/nttools/threed/tiimage/tmmode.x | 108 + pkg/utilities/nttools/threed/tiimage/tmscan.x | 96 + pkg/utilities/nttools/threed/titable.par | 7 + pkg/utilities/nttools/threed/titable/design1.txt | 224 ++ pkg/utilities/nttools/threed/titable/design2.txt | 244 ++ pkg/utilities/nttools/threed/titable/generic/mkpkg | 22 + .../nttools/threed/titable/generic/tichb.x | 52 + .../nttools/threed/titable/generic/tichc.x | 54 + .../nttools/threed/titable/generic/tichd.x | 52 + .../nttools/threed/titable/generic/tichi.x | 52 + .../nttools/threed/titable/generic/tichr.x | 52 + .../nttools/threed/titable/generic/tichs.x | 52 + .../nttools/threed/titable/generic/tirowsb.x | 71 + .../nttools/threed/titable/generic/tirowsc.x | 72 + .../nttools/threed/titable/generic/tirowsd.x | 71 + .../nttools/threed/titable/generic/tirowsi.x | 71 + .../nttools/threed/titable/generic/tirowsr.x | 71 + .../nttools/threed/titable/generic/tirowss.x | 71 + pkg/utilities/nttools/threed/titable/help.txt | 117 + pkg/utilities/nttools/threed/titable/list.tex | 979 ++++++ pkg/utilities/nttools/threed/titable/loc.txt | 11 + pkg/utilities/nttools/threed/titable/mkpkg | 36 + pkg/utilities/nttools/threed/titable/ticc.x | 56 + pkg/utilities/nttools/threed/titable/tich.gx | 74 + pkg/utilities/nttools/threed/titable/ticopy.x | 116 + pkg/utilities/nttools/threed/titable/tiheader.x | 192 ++ pkg/utilities/nttools/threed/titable/tinew.x | 101 + pkg/utilities/nttools/threed/titable/tinsert.x | 99 + pkg/utilities/nttools/threed/titable/tirows.gx | 98 + pkg/utilities/nttools/threed/titable/tisetc.x | 83 + pkg/utilities/nttools/threed/titable/titable.x | 83 + pkg/utilities/nttools/threed/titable/tiupdate.x | 39 + pkg/utilities/nttools/threed/tscopy.par | 5 + pkg/utilities/nttools/threed/tscopy/mkpkg | 14 + pkg/utilities/nttools/threed/tscopy/tbracket.x | 105 + pkg/utilities/nttools/threed/tscopy/tcpyone.x | 141 + pkg/utilities/nttools/threed/tscopy/tcpyrow.x | 79 + pkg/utilities/nttools/threed/tscopy/tscopy.x | 110 + pkg/utilities/nttools/threed/tximage.par | 5 + pkg/utilities/nttools/threed/tximage/mkpkg | 15 + pkg/utilities/nttools/threed/tximage/txicpy.x | 61 + pkg/utilities/nttools/threed/tximage/txihc.x | 53 + pkg/utilities/nttools/threed/tximage/tximage.x | 117 + pkg/utilities/nttools/threed/tximage/txione.x | 214 ++ pkg/utilities/nttools/threed/txtable.par | 6 + pkg/utilities/nttools/threed/txtable/generic/mkpkg | 22 + .../nttools/threed/txtable/generic/txtcptb.x | 34 + .../nttools/threed/txtable/generic/txtcptc.x | 35 + .../nttools/threed/txtable/generic/txtcptd.x | 34 + .../nttools/threed/txtable/generic/txtcpti.x | 34 + .../nttools/threed/txtable/generic/txtcptr.x | 34 + .../nttools/threed/txtable/generic/txtcpts.x | 34 + .../nttools/threed/txtable/generic/txthvb.x | 30 + .../nttools/threed/txtable/generic/txthvc.x | 30 + .../nttools/threed/txtable/generic/txthvd.x | 30 + .../nttools/threed/txtable/generic/txthvi.x | 30 + .../nttools/threed/txtable/generic/txthvr.x | 30 + .../nttools/threed/txtable/generic/txthvs.x | 30 + pkg/utilities/nttools/threed/txtable/mkpkg | 34 + pkg/utilities/nttools/threed/txtable/txtable.x | 121 + pkg/utilities/nttools/threed/txtable/txtcpt.gx | 53 + pkg/utilities/nttools/threed/txtable/txtcpy.x | 94 + pkg/utilities/nttools/threed/txtable/txtcpyco.x | 45 + pkg/utilities/nttools/threed/txtable/txtcpysc.x | 34 + pkg/utilities/nttools/threed/txtable/txthc.x | 85 + pkg/utilities/nttools/threed/txtable/txthv.gx | 55 + pkg/utilities/nttools/threed/txtable/txtone.x | 227 ++ pkg/utilities/nttools/threed/x_threed.x | 5 + pkg/utilities/nttools/thselect.par | 5 + pkg/utilities/nttools/tinfo.par | 15 + pkg/utilities/nttools/tinfo/mkpkg | 12 + pkg/utilities/nttools/tinfo/tinfo.x | 179 + pkg/utilities/nttools/tinfo/tlcol.x | 128 + pkg/utilities/nttools/tintegrate.par | 6 + pkg/utilities/nttools/tintegrate/mkpkg | 11 + pkg/utilities/nttools/tintegrate/tintegrate.x | 155 + pkg/utilities/nttools/tjoin.par | 9 + pkg/utilities/nttools/tjoin/closeiotab.x | 22 + pkg/utilities/nttools/tjoin/dojoin.x | 97 + pkg/utilities/nttools/tjoin/freetol.x | 15 + pkg/utilities/nttools/tjoin/isnumber.x | 35 + pkg/utilities/nttools/tjoin/issame.x | 127 + pkg/utilities/nttools/tjoin/mkjoin.x | 106 + pkg/utilities/nttools/tjoin/mkpkg | 23 + pkg/utilities/nttools/tjoin/openitab.x | 82 + pkg/utilities/nttools/tjoin/openotab.x | 91 + pkg/utilities/nttools/tjoin/readtol.x | 55 + pkg/utilities/nttools/tjoin/removejcol.x | 43 + pkg/utilities/nttools/tjoin/renamecol.x | 109 + pkg/utilities/nttools/tjoin/spptype.x | 29 + pkg/utilities/nttools/tjoin/tjoin.h | 27 + pkg/utilities/nttools/tjoin/tjoin.x | 124 + pkg/utilities/nttools/tlcol.par | 4 + pkg/utilities/nttools/tlinear.par | 10 + pkg/utilities/nttools/tlinear/mkpkg | 11 + pkg/utilities/nttools/tlinear/tlinear.x | 468 +++ pkg/utilities/nttools/tmatch.par | 18 + pkg/utilities/nttools/tmatch/getmatch.x | 101 + pkg/utilities/nttools/tmatch/getnorm.x | 67 + pkg/utilities/nttools/tmatch/getweight.x | 96 + pkg/utilities/nttools/tmatch/infomatch.x | 219 ++ pkg/utilities/nttools/tmatch/mkpkg | 20 + pkg/utilities/nttools/tmatch/putmatch.x | 102 + pkg/utilities/nttools/tmatch/rowname.x | 61 + pkg/utilities/nttools/tmatch/setindex.x | 13 + pkg/utilities/nttools/tmatch/sortclose.x | 50 + pkg/utilities/nttools/tmatch/sortdist.x | 50 + pkg/utilities/nttools/tmatch/tmatch.x | 138 + pkg/utilities/nttools/tmerge.par | 9 + pkg/utilities/nttools/tmerge/mkpkg | 20 + pkg/utilities/nttools/tmerge/tmerge.x | 425 +++ pkg/utilities/nttools/tprint.par | 16 + pkg/utilities/nttools/tprint/mkpkg | 15 + pkg/utilities/nttools/tprint/notes | 40 + pkg/utilities/nttools/tprint/tdump.x | 486 +++ pkg/utilities/nttools/tprint/tprhtml.x | 592 ++++ pkg/utilities/nttools/tprint/tprint.h | 5 + pkg/utilities/nttools/tprint/tprint.x | 535 +++ pkg/utilities/nttools/tprint/tprlatex.x | 579 ++++ pkg/utilities/nttools/tprint/tprplain.x | 530 +++ pkg/utilities/nttools/tproduct.par | 4 + pkg/utilities/nttools/tproduct/mkpkg | 11 + pkg/utilities/nttools/tproduct/tproduct.x | 113 + pkg/utilities/nttools/tproject.par | 5 + pkg/utilities/nttools/tproject/mkpkg | 13 + pkg/utilities/nttools/tproject/nextuniq.x | 39 + pkg/utilities/nttools/tproject/tproject.x | 100 + pkg/utilities/nttools/tproject/wproject.x | 64 + pkg/utilities/nttools/tquery.par | 9 + pkg/utilities/nttools/tquery/doquery.x | 72 + pkg/utilities/nttools/tquery/mkpkg | 13 + pkg/utilities/nttools/tquery/tquery.x | 113 + pkg/utilities/nttools/tquery/wquery.x | 50 + pkg/utilities/nttools/tread.par | 4 + pkg/utilities/nttools/trebin.par | 14 + pkg/utilities/nttools/trebin/mkpkg | 27 + pkg/utilities/nttools/trebin/tnamcls.x | 24 + pkg/utilities/nttools/trebin/tnamgio.x | 79 + pkg/utilities/nttools/trebin/tnaminit.x | 75 + pkg/utilities/nttools/trebin/trebin.h | 5 + pkg/utilities/nttools/trebin/trebin.x | 136 + pkg/utilities/nttools/trebin/tucspl.f | 52 + pkg/utilities/nttools/trebin/tudcol.x | 140 + pkg/utilities/nttools/trebin/tugcol.x | 87 + pkg/utilities/nttools/trebin/tugetput.x | 142 + pkg/utilities/nttools/trebin/tuhunt.f | 103 + pkg/utilities/nttools/trebin/tuiep3.f | 71 + pkg/utilities/nttools/trebin/tuifit.x | 63 + pkg/utilities/nttools/trebin/tuinterp.x | 139 + pkg/utilities/nttools/trebin/tuiset.x | 26 + pkg/utilities/nttools/trebin/tuispl.f | 32 + pkg/utilities/nttools/trebin/tuival.x | 272 ++ pkg/utilities/nttools/trebin/tutrim.x | 43 + pkg/utilities/nttools/trebin/tuxget.x | 134 + pkg/utilities/nttools/tselect.par | 4 + pkg/utilities/nttools/tselect/mkpkg | 12 + pkg/utilities/nttools/tselect/subset.x | 83 + pkg/utilities/nttools/tselect/tselect.x | 83 + pkg/utilities/nttools/tsort.par | 5 + pkg/utilities/nttools/tsort/mkpkg | 14 + pkg/utilities/nttools/tsort/tblextsort.x | 496 +++ pkg/utilities/nttools/tsort/tblintsort.x | 48 + pkg/utilities/nttools/tsort/tblmaxrow.x | 39 + pkg/utilities/nttools/tsort/tsort.x | 98 + pkg/utilities/nttools/tstat.par | 21 + pkg/utilities/nttools/tstat/mkpkg | 13 + pkg/utilities/nttools/tstat/thistogram.h | 8 + pkg/utilities/nttools/tstat/thistogram.x | 348 ++ pkg/utilities/nttools/tstat/thoptions.x | 343 ++ pkg/utilities/nttools/tstat/tstat.x | 465 +++ pkg/utilities/nttools/ttranspose.par | 6 + pkg/utilities/nttools/ttranspose/mkpkg | 11 + pkg/utilities/nttools/ttranspose/ttranspose.x | 419 +++ pkg/utilities/nttools/ttranspose/ttrflip.x | 266 ++ pkg/utilities/nttools/tunits.par | 8 + pkg/utilities/nttools/tunits/abrev.tab | 62 + pkg/utilities/nttools/tunits/abrev.x | 113 + pkg/utilities/nttools/tunits/convertcol.x | 68 + pkg/utilities/nttools/tunits/factor.x | 125 + pkg/utilities/nttools/tunits/mkpkg | 19 + pkg/utilities/nttools/tunits/parseunits.com | 9 + pkg/utilities/nttools/tunits/parseunits.x | 624 ++++ pkg/utilities/nttools/tunits/parseunits.y | 322 ++ pkg/utilities/nttools/tunits/tuniterr.x | 24 + pkg/utilities/nttools/tunits/tunits.h | 14 + pkg/utilities/nttools/tunits/tunits.x | 112 + pkg/utilities/nttools/tunits/unhash.x | 212 ++ pkg/utilities/nttools/tunits/units.tab | 60 + pkg/utilities/nttools/tunits/units.x | 162 + pkg/utilities/nttools/tunits/unstr.x | 381 +++ pkg/utilities/nttools/tupar.par | 9 + pkg/utilities/nttools/tupar/mkpkg | 12 + pkg/utilities/nttools/tupar/tuinstr.x | 971 ++++++ pkg/utilities/nttools/tupar/tupar.h | 3 + pkg/utilities/nttools/tupar/tupar.x | 260 ++ pkg/utilities/nttools/x_nttools.x | 50 + pkg/utilities/nttools/zz.xml | 3427 ++++++++++++++++++++ pkg/utilities/nttools/zz_bad.xml | 3427 ++++++++++++++++++++ pkg/utilities/nttools/zz_rewrite.xml | 1191 +++++++ pkg/utilities/pffctn.x | 17 + pkg/utilities/pfregres.f | 183 ++ pkg/utilities/polyfit.par | 5 + pkg/utilities/split.par | 6 + pkg/utilities/surfit.par | 18 + pkg/utilities/t_curfit.x | 446 +++ pkg/utilities/t_detab.x | 30 + pkg/utilities/t_entab.x | 31 + pkg/utilities/t_lcase.x | 42 + pkg/utilities/t_polyfit.x | 244 ++ pkg/utilities/t_split.x | 108 + pkg/utilities/t_surfit.x | 342 ++ pkg/utilities/t_translit.x | 294 ++ pkg/utilities/t_ucase.x | 42 + pkg/utilities/t_urand.x | 47 + pkg/utilities/translit.par | 5 + pkg/utilities/ucase.par | 1 + pkg/utilities/urand.par | 5 + pkg/utilities/utilities.cl | 29 + pkg/utilities/utilities.hd | 26 + pkg/utilities/utilities.men | 13 + pkg/utilities/utilities.par | 1 + pkg/utilities/x_utilities.x | 14 + 662 files changed, 84366 insertions(+) create mode 100644 pkg/utilities/README create mode 100644 pkg/utilities/Revisions create mode 100644 pkg/utilities/bases.cl create mode 100644 pkg/utilities/curfit.gx create mode 100644 pkg/utilities/curfit.h create mode 100644 pkg/utilities/curfit.par create mode 100644 pkg/utilities/curfit.x create mode 100644 pkg/utilities/decod_tablst.x create mode 100644 pkg/utilities/detab.par create mode 100644 pkg/utilities/doc/bases.hlp create mode 100644 pkg/utilities/doc/curfit.hlp create mode 100644 pkg/utilities/doc/detab.hlp create mode 100644 pkg/utilities/doc/entab.hlp create mode 100644 pkg/utilities/doc/lcase.hlp create mode 100644 pkg/utilities/doc/polyfit.hlp create mode 100644 pkg/utilities/doc/split.hlp create mode 100644 pkg/utilities/doc/surfit.hlp create mode 100644 pkg/utilities/doc/translit.hlp create mode 100644 pkg/utilities/doc/ucase.hlp create mode 100644 pkg/utilities/doc/urand.hlp create mode 100644 pkg/utilities/entab.par create mode 100644 pkg/utilities/lcase.par create mode 100644 pkg/utilities/mkpkg create mode 100644 pkg/utilities/nttools/README create mode 100644 pkg/utilities/nttools/atools/mkpkg create mode 100644 pkg/utilities/nttools/atools/taextract.x create mode 100644 pkg/utilities/nttools/atools/taincr.x create mode 100644 pkg/utilities/nttools/atools/tainsert.x create mode 100644 pkg/utilities/nttools/copyone/addslash.x create mode 100644 pkg/utilities/nttools/copyone/datatype.x create mode 100644 pkg/utilities/nttools/copyone/filetype.h create mode 100644 pkg/utilities/nttools/copyone/filetype.x create mode 100644 pkg/utilities/nttools/copyone/filetype.x.OLD create mode 100644 pkg/utilities/nttools/copyone/getimghdr.x create mode 100644 pkg/utilities/nttools/copyone/gettabdat.x create mode 100644 pkg/utilities/nttools/copyone/gettabhdr.x create mode 100644 pkg/utilities/nttools/copyone/isdouble.x create mode 100644 pkg/utilities/nttools/copyone/keypar.x create mode 100644 pkg/utilities/nttools/copyone/keytab.x create mode 100644 pkg/utilities/nttools/copyone/mkpkg create mode 100644 pkg/utilities/nttools/copyone/parkey.x create mode 100644 pkg/utilities/nttools/copyone/partab.x create mode 100644 pkg/utilities/nttools/copyone/putimghdr.x create mode 100644 pkg/utilities/nttools/copyone/puttabdat.x create mode 100644 pkg/utilities/nttools/copyone/puttabhdr.x create mode 100644 pkg/utilities/nttools/copyone/tabaccess.x create mode 100644 pkg/utilities/nttools/copyone/tabhdrtyp.x create mode 100644 pkg/utilities/nttools/copyone/tabkey.x create mode 100644 pkg/utilities/nttools/copyone/tabpar.x create mode 100644 pkg/utilities/nttools/doc/axispar.hlp create mode 100644 pkg/utilities/nttools/doc/dvpar.hlp create mode 100644 pkg/utilities/nttools/doc/gtedit.hlp create mode 100644 pkg/utilities/nttools/doc/gtpar.hlp create mode 100644 pkg/utilities/nttools/doc/imtab.hlp create mode 100644 pkg/utilities/nttools/doc/keypar.hlp create mode 100644 pkg/utilities/nttools/doc/keyselect.hlp create mode 100644 pkg/utilities/nttools/doc/keytab.hlp create mode 100644 pkg/utilities/nttools/doc/parkey.hlp create mode 100644 pkg/utilities/nttools/doc/partab.hlp create mode 100644 pkg/utilities/nttools/doc/pltpar.hlp create mode 100644 pkg/utilities/nttools/doc/tabim.hlp create mode 100644 pkg/utilities/nttools/doc/tabkey.hlp create mode 100644 pkg/utilities/nttools/doc/tabpar.hlp create mode 100644 pkg/utilities/nttools/doc/taextract.hlp create mode 100644 pkg/utilities/nttools/doc/tainsert.hlp create mode 100644 pkg/utilities/nttools/doc/tcalc.hlp create mode 100644 pkg/utilities/nttools/doc/tchcol.hlp create mode 100644 pkg/utilities/nttools/doc/tcheck.hlp create mode 100644 pkg/utilities/nttools/doc/tchsize.hlp create mode 100644 pkg/utilities/nttools/doc/tcopy.hlp create mode 100644 pkg/utilities/nttools/doc/tcreate.hlp create mode 100644 pkg/utilities/nttools/doc/tdelete.hlp create mode 100644 pkg/utilities/nttools/doc/tdiffer.hlp create mode 100644 pkg/utilities/nttools/doc/tdump.hlp create mode 100644 pkg/utilities/nttools/doc/tedit.hlp create mode 100644 pkg/utilities/nttools/doc/texpand.hlp create mode 100644 pkg/utilities/nttools/doc/thedit.hlp create mode 100644 pkg/utilities/nttools/doc/thistogram.hlp create mode 100644 pkg/utilities/nttools/doc/thselect.hlp create mode 100644 pkg/utilities/nttools/doc/tinfo.hlp create mode 100644 pkg/utilities/nttools/doc/tintegrate.hlp create mode 100644 pkg/utilities/nttools/doc/tjoin.hlp create mode 100644 pkg/utilities/nttools/doc/tlcol.hlp create mode 100644 pkg/utilities/nttools/doc/tlinear.hlp create mode 100644 pkg/utilities/nttools/doc/tmatch.hlp create mode 100644 pkg/utilities/nttools/doc/tmerge.hlp create mode 100644 pkg/utilities/nttools/doc/tprint.hlp create mode 100644 pkg/utilities/nttools/doc/tproduct.hlp create mode 100644 pkg/utilities/nttools/doc/tproject.hlp create mode 100644 pkg/utilities/nttools/doc/tquery.hlp create mode 100644 pkg/utilities/nttools/doc/tread.hlp create mode 100644 pkg/utilities/nttools/doc/trebin.hlp create mode 100644 pkg/utilities/nttools/doc/tselect.hlp create mode 100644 pkg/utilities/nttools/doc/tsort.hlp create mode 100644 pkg/utilities/nttools/doc/tstat.hlp create mode 100644 pkg/utilities/nttools/doc/ttranspose.hlp create mode 100644 pkg/utilities/nttools/doc/tunits.hlp create mode 100644 pkg/utilities/nttools/doc/tupar.hlp create mode 100644 pkg/utilities/nttools/doc/wcspars.hlp create mode 100644 pkg/utilities/nttools/doc/wlpars.hlp create mode 100644 pkg/utilities/nttools/gtedit.par create mode 100644 pkg/utilities/nttools/gtedit/gtdelete.x create mode 100644 pkg/utilities/nttools/gtedit/gtdodel.x create mode 100644 pkg/utilities/nttools/gtedit/gtedit.key create mode 100644 pkg/utilities/nttools/gtedit/gthinfo.x create mode 100644 pkg/utilities/nttools/gtedit/gtplot.x create mode 100644 pkg/utilities/nttools/gtedit/gtrdxycol.x create mode 100644 pkg/utilities/nttools/gtedit/gtupdate.x create mode 100644 pkg/utilities/nttools/gtedit/gtwrdata.x create mode 100644 pkg/utilities/nttools/gtedit/gtwrhead.x create mode 100644 pkg/utilities/nttools/gtedit/mkpkg create mode 100644 pkg/utilities/nttools/gtedit/t_gtedit.x create mode 100644 pkg/utilities/nttools/gtpar.par create mode 100644 pkg/utilities/nttools/imtab.par create mode 100644 pkg/utilities/nttools/imtab/imtab.h create mode 100644 pkg/utilities/nttools/imtab/imtab.x create mode 100644 pkg/utilities/nttools/imtab/itbwcs.x create mode 100644 pkg/utilities/nttools/imtab/mkpkg create mode 100644 pkg/utilities/nttools/imtab/tabim.x create mode 100644 pkg/utilities/nttools/keypar.par create mode 100644 pkg/utilities/nttools/keyselect.par create mode 100644 pkg/utilities/nttools/keyselect/expr.x create mode 100644 pkg/utilities/nttools/keyselect/keyselect.com create mode 100644 pkg/utilities/nttools/keyselect/keyselect.h create mode 100644 pkg/utilities/nttools/keyselect/keyselect.x create mode 100644 pkg/utilities/nttools/keyselect/keyword.x create mode 100644 pkg/utilities/nttools/keyselect/list.x create mode 100644 pkg/utilities/nttools/keyselect/mkpkg create mode 100644 pkg/utilities/nttools/keyselect/tab.x create mode 100644 pkg/utilities/nttools/keytab.par create mode 100644 pkg/utilities/nttools/lib/allcols.x create mode 100644 pkg/utilities/nttools/lib/allrows.x create mode 100644 pkg/utilities/nttools/lib/compare.com create mode 100644 pkg/utilities/nttools/lib/compare.x create mode 100644 pkg/utilities/nttools/lib/ftnexpr.x create mode 100644 pkg/utilities/nttools/lib/gettabcol.x create mode 100644 pkg/utilities/nttools/lib/inquotes.x create mode 100644 pkg/utilities/nttools/lib/invert.x create mode 100644 pkg/utilities/nttools/lib/mjd.x create mode 100644 pkg/utilities/nttools/lib/mkpkg create mode 100644 pkg/utilities/nttools/lib/movenulls.x create mode 100644 pkg/utilities/nttools/lib/msort.x create mode 100644 pkg/utilities/nttools/lib/newcolnam.x create mode 100644 pkg/utilities/nttools/lib/reloperr.h create mode 100644 pkg/utilities/nttools/lib/reorder.x create mode 100644 pkg/utilities/nttools/lib/select.x create mode 100644 pkg/utilities/nttools/lib/tabvar.x create mode 100644 pkg/utilities/nttools/lib/tbfile.x create mode 100644 pkg/utilities/nttools/lib/tbleval.x create mode 100644 pkg/utilities/nttools/lib/tbljoin.x create mode 100644 pkg/utilities/nttools/lib/tblmerge.x create mode 100644 pkg/utilities/nttools/lib/tblsearch.x create mode 100644 pkg/utilities/nttools/lib/tblsort.x create mode 100644 pkg/utilities/nttools/lib/tblsort1.x create mode 100644 pkg/utilities/nttools/lib/tblsortm.x create mode 100644 pkg/utilities/nttools/lib/tblterm.com create mode 100644 pkg/utilities/nttools/lib/tblterm.x create mode 100644 pkg/utilities/nttools/lib/tctexp.x create mode 100644 pkg/utilities/nttools/lib/tldtype.x create mode 100644 pkg/utilities/nttools/lib/tuopen.x create mode 100644 pkg/utilities/nttools/lib/unique.x create mode 100644 pkg/utilities/nttools/mkpkg create mode 100644 pkg/utilities/nttools/nttools.cl create mode 100644 pkg/utilities/nttools/nttools.hd create mode 100644 pkg/utilities/nttools/nttools.hlp create mode 100644 pkg/utilities/nttools/nttools.men create mode 100644 pkg/utilities/nttools/nttools.par create mode 100644 pkg/utilities/nttools/parkey.par create mode 100644 pkg/utilities/nttools/partab.par create mode 100644 pkg/utilities/nttools/stxtools/changt.x create mode 100644 pkg/utilities/nttools/stxtools/checkdim.x create mode 100644 pkg/utilities/nttools/stxtools/cif.h create mode 100644 pkg/utilities/nttools/stxtools/cif.x create mode 100644 pkg/utilities/nttools/stxtools/clgnone.x create mode 100644 pkg/utilities/nttools/stxtools/copyimg.x create mode 100644 pkg/utilities/nttools/stxtools/doc/wcs.doc create mode 100644 pkg/utilities/nttools/stxtools/errxit.x create mode 100644 pkg/utilities/nttools/stxtools/fbuild.x create mode 100644 pkg/utilities/nttools/stxtools/fparse.x create mode 100644 pkg/utilities/nttools/stxtools/grmimy.x create mode 100644 pkg/utilities/nttools/stxtools/isblank.x create mode 100644 pkg/utilities/nttools/stxtools/lubksb.f create mode 100644 pkg/utilities/nttools/stxtools/lubksd.f create mode 100644 pkg/utilities/nttools/stxtools/ludcmd.x create mode 100644 pkg/utilities/nttools/stxtools/ludcmp.x create mode 100644 pkg/utilities/nttools/stxtools/mkpkg create mode 100644 pkg/utilities/nttools/stxtools/od/mkpkg create mode 100644 pkg/utilities/nttools/stxtools/od/od.h create mode 100644 pkg/utilities/nttools/stxtools/od/odget.x create mode 100644 pkg/utilities/nttools/stxtools/od/odmap.x create mode 100644 pkg/utilities/nttools/stxtools/od/odopep.x create mode 100644 pkg/utilities/nttools/stxtools/od/odpare.x create mode 100644 pkg/utilities/nttools/stxtools/od/odput.x create mode 100644 pkg/utilities/nttools/stxtools/od/odsetn.x create mode 100644 pkg/utilities/nttools/stxtools/od/odunmp.x create mode 100644 pkg/utilities/nttools/stxtools/od/odwcsn.x create mode 100644 pkg/utilities/nttools/stxtools/postexit.x create mode 100644 pkg/utilities/nttools/stxtools/savgol.x create mode 100644 pkg/utilities/nttools/stxtools/sbuf.h create mode 100644 pkg/utilities/nttools/stxtools/sbuf.x create mode 100644 pkg/utilities/nttools/stxtools/sgcone.x create mode 100644 pkg/utilities/nttools/stxtools/similar.x create mode 100644 pkg/utilities/nttools/stxtools/sp_util/mkpkg create mode 100644 pkg/utilities/nttools/stxtools/sp_util/spchag.x create mode 100644 pkg/utilities/nttools/stxtools/sp_util/spdise.x create mode 100644 pkg/utilities/nttools/stxtools/sp_util/spmapt.x create mode 100644 pkg/utilities/nttools/stxtools/sp_util/sprote.x create mode 100644 pkg/utilities/nttools/stxtools/sp_util/spstry.x create mode 100644 pkg/utilities/nttools/stxtools/sp_util/sptras.x create mode 100644 pkg/utilities/nttools/stxtools/sp_util/spw2ld.x create mode 100644 pkg/utilities/nttools/stxtools/sp_util/spwcss.x create mode 100644 pkg/utilities/nttools/stxtools/strjust.x create mode 100644 pkg/utilities/nttools/stxtools/stxgetcoord.x create mode 100644 pkg/utilities/nttools/stxtools/template.h create mode 100644 pkg/utilities/nttools/stxtools/tpbreak.x create mode 100644 pkg/utilities/nttools/stxtools/tpclose.x create mode 100644 pkg/utilities/nttools/stxtools/tpcount.x create mode 100644 pkg/utilities/nttools/stxtools/tpfetch.x create mode 100644 pkg/utilities/nttools/stxtools/tpgroup.x create mode 100644 pkg/utilities/nttools/stxtools/tpimtype.x create mode 100644 pkg/utilities/nttools/stxtools/tpopen.x create mode 100644 pkg/utilities/nttools/stxtools/tpparse.x create mode 100644 pkg/utilities/nttools/stxtools/vex.com create mode 100644 pkg/utilities/nttools/stxtools/vex.h create mode 100644 pkg/utilities/nttools/stxtools/vexcompile.x create mode 100644 pkg/utilities/nttools/stxtools/vexcompile.y create mode 100644 pkg/utilities/nttools/stxtools/vexeval.x create mode 100644 pkg/utilities/nttools/stxtools/vexfree.x create mode 100644 pkg/utilities/nttools/stxtools/vexfunc.x create mode 100644 pkg/utilities/nttools/stxtools/vexstack.x create mode 100644 pkg/utilities/nttools/stxtools/wcslab/mkpkg create mode 100644 pkg/utilities/nttools/stxtools/wcslab/mkpkg.ori create mode 100644 pkg/utilities/nttools/stxtools/wcslab/psiescape.h create mode 100644 pkg/utilities/nttools/stxtools/wcslab/t_wcslab.x create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wcs_desc.h create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wcslab.h create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wcslab.x create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wlgrid.x create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wllabel.x create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wllabel.x.ori create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wlsetup.x create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wlutil.x create mode 100644 pkg/utilities/nttools/stxtools/wcslab/wlwcslab.x create mode 100644 pkg/utilities/nttools/stxtools/word.x create mode 100644 pkg/utilities/nttools/stxtools/xtwcs.x create mode 100644 pkg/utilities/nttools/tabim.par create mode 100644 pkg/utilities/nttools/tabkey.par create mode 100644 pkg/utilities/nttools/tabpar.par create mode 100644 pkg/utilities/nttools/tabvar.com create mode 100644 pkg/utilities/nttools/taextract.par create mode 100644 pkg/utilities/nttools/tainsert.par create mode 100644 pkg/utilities/nttools/tcalc.par create mode 100644 pkg/utilities/nttools/tcalc/mkpkg create mode 100644 pkg/utilities/nttools/tcalc/tcalc.x create mode 100644 pkg/utilities/nttools/tchcol.par create mode 100644 pkg/utilities/nttools/tchcol/mkpkg create mode 100644 pkg/utilities/nttools/tchcol/tchcol.x create mode 100644 pkg/utilities/nttools/tcheck.par create mode 100644 pkg/utilities/nttools/tcheck/cmdsplit.x create mode 100644 pkg/utilities/nttools/tcheck/mkpkg create mode 100644 pkg/utilities/nttools/tcheck/tcheck.h create mode 100644 pkg/utilities/nttools/tcheck/tcheck.x create mode 100644 pkg/utilities/nttools/tcheck/wrtcheck.x create mode 100644 pkg/utilities/nttools/tchsize.par create mode 100644 pkg/utilities/nttools/tchsize/mkpkg create mode 100644 pkg/utilities/nttools/tchsize/tchsize.x create mode 100644 pkg/utilities/nttools/tcopy.par create mode 100644 pkg/utilities/nttools/tcopy/iswholetab.x create mode 100644 pkg/utilities/nttools/tcopy/mkpkg create mode 100644 pkg/utilities/nttools/tcopy/tcopy.x create mode 100644 pkg/utilities/nttools/tcopy/tdelete.x create mode 100644 pkg/utilities/nttools/tcopy/trename.x create mode 100644 pkg/utilities/nttools/tcreate.par create mode 100644 pkg/utilities/nttools/tcreate/gnextl.x create mode 100644 pkg/utilities/nttools/tcreate/mkpkg create mode 100644 pkg/utilities/nttools/tcreate/tcreate.x create mode 100644 pkg/utilities/nttools/tdelete.par create mode 100644 pkg/utilities/nttools/tdiffer.par create mode 100644 pkg/utilities/nttools/tdiffer/mkpkg create mode 100644 pkg/utilities/nttools/tdiffer/tbldiff.x create mode 100644 pkg/utilities/nttools/tdiffer/tdiffer.x create mode 100644 pkg/utilities/nttools/tdump.par create mode 100644 pkg/utilities/nttools/tedit.par create mode 100644 pkg/utilities/nttools/tedit/bell.x create mode 100644 pkg/utilities/nttools/tedit/command.com create mode 100644 pkg/utilities/nttools/tedit/command.h create mode 100644 pkg/utilities/nttools/tedit/command.x create mode 100644 pkg/utilities/nttools/tedit/display/curses.h create mode 100644 pkg/utilities/nttools/tedit/display/curses/README create mode 100644 pkg/utilities/nttools/tedit/display/curses/addch.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/addstr.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/bindstruct.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/box.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/clear.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/clearok.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/clrtobot.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/clrtoeol.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/delch.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/deleteln.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/delwin.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/echo.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/endwin.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/erase.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/freescreen.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/getch.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/getscreen.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/getstr.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/getstruct.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/getyx.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/hidewin.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/inch.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/initscr.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/insch.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/insertln.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/leaveok.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/mkpkg create mode 100644 pkg/utilities/nttools/tedit/display/curses/move.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/mvwin.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/mvword.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/newwin.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/omkpkg create mode 100644 pkg/utilities/nttools/tedit/display/curses/putscreen.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/refresh.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/savewin.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/scrollok.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/showwin.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/standout.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/wdimen.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/window.com create mode 100644 pkg/utilities/nttools/tedit/display/curses/window.h create mode 100644 pkg/utilities/nttools/tedit/display/curses/winstat.x create mode 100644 pkg/utilities/nttools/tedit/display/curses/wslide.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/README create mode 100644 pkg/utilities/nttools/tedit/display/forms/fmbegin.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/fmcheck.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/fmend.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/fmgetform.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/fmhelp.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/fmmkform.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/fmprompt.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/fmredraw.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/formfn.h create mode 100644 pkg/utilities/nttools/tedit/display/forms/formfn.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/forms.com create mode 100644 pkg/utilities/nttools/tedit/display/forms/linefn.h create mode 100644 pkg/utilities/nttools/tedit/display/forms/linefn.x create mode 100644 pkg/utilities/nttools/tedit/display/forms/mkpkg create mode 100644 pkg/utilities/nttools/tedit/display/forms/promptfn.h create mode 100644 pkg/utilities/nttools/tedit/display/forms/promptfn.x create mode 100644 pkg/utilities/nttools/tedit/display/mkpkg create mode 100644 pkg/utilities/nttools/tedit/display/screen/README create mode 100644 pkg/utilities/nttools/tedit/display/screen/kbegin.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/kcompile.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/kconvert.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/kdoline.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/kend.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/kget.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/khelp.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/kpushbk.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/mkpkg create mode 100644 pkg/utilities/nttools/tedit/display/screen/psbeep.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/psbegin.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/psend.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/psfill.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/psheight.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/psintersect.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/psscreen.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/pssendcap.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/pssetcur.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/psslide.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/pssynch.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/pswidth.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/pswrite.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/pswrtcells.x create mode 100644 pkg/utilities/nttools/tedit/display/screen/screen.com create mode 100644 pkg/utilities/nttools/tedit/edit.x create mode 100644 pkg/utilities/nttools/tedit/field.h create mode 100644 pkg/utilities/nttools/tedit/field.x create mode 100644 pkg/utilities/nttools/tedit/mkpkg create mode 100644 pkg/utilities/nttools/tedit/paste.h create mode 100644 pkg/utilities/nttools/tedit/paste.x create mode 100644 pkg/utilities/nttools/tedit/prompt.x create mode 100644 pkg/utilities/nttools/tedit/screen.h create mode 100644 pkg/utilities/nttools/tedit/screen.x create mode 100644 pkg/utilities/nttools/tedit/substitute.x create mode 100644 pkg/utilities/nttools/tedit/table.h create mode 100644 pkg/utilities/nttools/tedit/table.x create mode 100644 pkg/utilities/nttools/tedit/tedit.key create mode 100644 pkg/utilities/nttools/tedit/tedit.x create mode 100644 pkg/utilities/nttools/tedit/tread.x create mode 100644 pkg/utilities/nttools/tedit/window.com create mode 100644 pkg/utilities/nttools/tedit/window.x create mode 100644 pkg/utilities/nttools/texpand.par create mode 100644 pkg/utilities/nttools/texpand/dbgrules.x create mode 100644 pkg/utilities/nttools/texpand/lexer.x create mode 100644 pkg/utilities/nttools/texpand/lexoper.h create mode 100644 pkg/utilities/nttools/texpand/mkpkg create mode 100644 pkg/utilities/nttools/texpand/mkrules.x create mode 100644 pkg/utilities/nttools/texpand/movelem.x create mode 100644 pkg/utilities/nttools/texpand/movtbrow.x create mode 100644 pkg/utilities/nttools/texpand/parser.com create mode 100644 pkg/utilities/nttools/texpand/parser.x create mode 100644 pkg/utilities/nttools/texpand/pushstack.x create mode 100644 pkg/utilities/nttools/texpand/span.x create mode 100644 pkg/utilities/nttools/texpand/texpand.x create mode 100644 pkg/utilities/nttools/texpand/userules.x create mode 100644 pkg/utilities/nttools/texpand/x_texpand.x create mode 100644 pkg/utilities/nttools/thedit.par create mode 100644 pkg/utilities/nttools/thedit/mkpkg create mode 100644 pkg/utilities/nttools/thedit/t_thedit.x create mode 100644 pkg/utilities/nttools/thedit/t_thselect.x create mode 100644 pkg/utilities/nttools/thedit/tkw.x create mode 100644 pkg/utilities/nttools/thistogram.par create mode 100644 pkg/utilities/nttools/threed/doc/selectors.hlp create mode 100644 pkg/utilities/nttools/threed/doc/tiimage.hlp create mode 100644 pkg/utilities/nttools/threed/doc/titable.hlp create mode 100644 pkg/utilities/nttools/threed/doc/tscopy.hlp create mode 100644 pkg/utilities/nttools/threed/doc/tximage.hlp create mode 100644 pkg/utilities/nttools/threed/doc/txtable.hlp create mode 100644 pkg/utilities/nttools/threed/mkpkg create mode 100644 pkg/utilities/nttools/threed/tblerr.h create mode 100644 pkg/utilities/nttools/threed/tbtables.h create mode 100644 pkg/utilities/nttools/threed/tiimage.par create mode 100644 pkg/utilities/nttools/threed/tiimage/design1.txt create mode 100644 pkg/utilities/nttools/threed/tiimage/generic/mkpkg create mode 100644 pkg/utilities/nttools/threed/tiimage/generic/tmcp1d.x create mode 100644 pkg/utilities/nttools/threed/tiimage/generic/tmcp1i.x create mode 100644 pkg/utilities/nttools/threed/tiimage/generic/tmcp1r.x create mode 100644 pkg/utilities/nttools/threed/tiimage/generic/tmcp1s.x create mode 100644 pkg/utilities/nttools/threed/tiimage/list.tex create mode 100644 pkg/utilities/nttools/threed/tiimage/list.toc create mode 100644 pkg/utilities/nttools/threed/tiimage/loc.txt create mode 100644 pkg/utilities/nttools/threed/tiimage/mkpkg create mode 100644 pkg/utilities/nttools/threed/tiimage/tiimage.h create mode 100644 pkg/utilities/nttools/threed/tiimage/tiimage.x create mode 100644 pkg/utilities/nttools/threed/tiimage/tmcopy.x create mode 100644 pkg/utilities/nttools/threed/tiimage/tmcp1.gx create mode 100644 pkg/utilities/nttools/threed/tiimage/tmhc.x create mode 100644 pkg/utilities/nttools/threed/tiimage/tmheader.x create mode 100644 pkg/utilities/nttools/threed/tiimage/tmloop.x create mode 100644 pkg/utilities/nttools/threed/tiimage/tmmode.x create mode 100644 pkg/utilities/nttools/threed/tiimage/tmscan.x create mode 100644 pkg/utilities/nttools/threed/titable.par create mode 100644 pkg/utilities/nttools/threed/titable/design1.txt create mode 100644 pkg/utilities/nttools/threed/titable/design2.txt create mode 100644 pkg/utilities/nttools/threed/titable/generic/mkpkg create mode 100644 pkg/utilities/nttools/threed/titable/generic/tichb.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tichc.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tichd.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tichi.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tichr.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tichs.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tirowsb.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tirowsc.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tirowsd.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tirowsi.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tirowsr.x create mode 100644 pkg/utilities/nttools/threed/titable/generic/tirowss.x create mode 100644 pkg/utilities/nttools/threed/titable/help.txt create mode 100644 pkg/utilities/nttools/threed/titable/list.tex create mode 100644 pkg/utilities/nttools/threed/titable/loc.txt create mode 100644 pkg/utilities/nttools/threed/titable/mkpkg create mode 100644 pkg/utilities/nttools/threed/titable/ticc.x create mode 100644 pkg/utilities/nttools/threed/titable/tich.gx create mode 100644 pkg/utilities/nttools/threed/titable/ticopy.x create mode 100644 pkg/utilities/nttools/threed/titable/tiheader.x create mode 100644 pkg/utilities/nttools/threed/titable/tinew.x create mode 100644 pkg/utilities/nttools/threed/titable/tinsert.x create mode 100644 pkg/utilities/nttools/threed/titable/tirows.gx create mode 100644 pkg/utilities/nttools/threed/titable/tisetc.x create mode 100644 pkg/utilities/nttools/threed/titable/titable.x create mode 100644 pkg/utilities/nttools/threed/titable/tiupdate.x create mode 100644 pkg/utilities/nttools/threed/tscopy.par create mode 100644 pkg/utilities/nttools/threed/tscopy/mkpkg create mode 100644 pkg/utilities/nttools/threed/tscopy/tbracket.x create mode 100644 pkg/utilities/nttools/threed/tscopy/tcpyone.x create mode 100644 pkg/utilities/nttools/threed/tscopy/tcpyrow.x create mode 100644 pkg/utilities/nttools/threed/tscopy/tscopy.x create mode 100644 pkg/utilities/nttools/threed/tximage.par create mode 100644 pkg/utilities/nttools/threed/tximage/mkpkg create mode 100644 pkg/utilities/nttools/threed/tximage/txicpy.x create mode 100644 pkg/utilities/nttools/threed/tximage/txihc.x create mode 100644 pkg/utilities/nttools/threed/tximage/tximage.x create mode 100644 pkg/utilities/nttools/threed/tximage/txione.x create mode 100644 pkg/utilities/nttools/threed/txtable.par create mode 100644 pkg/utilities/nttools/threed/txtable/generic/mkpkg create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txtcptb.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txtcptc.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txtcptd.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txtcpti.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txtcptr.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txtcpts.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txthvb.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txthvc.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txthvd.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txthvi.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txthvr.x create mode 100644 pkg/utilities/nttools/threed/txtable/generic/txthvs.x create mode 100644 pkg/utilities/nttools/threed/txtable/mkpkg create mode 100644 pkg/utilities/nttools/threed/txtable/txtable.x create mode 100644 pkg/utilities/nttools/threed/txtable/txtcpt.gx create mode 100644 pkg/utilities/nttools/threed/txtable/txtcpy.x create mode 100644 pkg/utilities/nttools/threed/txtable/txtcpyco.x create mode 100644 pkg/utilities/nttools/threed/txtable/txtcpysc.x create mode 100644 pkg/utilities/nttools/threed/txtable/txthc.x create mode 100644 pkg/utilities/nttools/threed/txtable/txthv.gx create mode 100644 pkg/utilities/nttools/threed/txtable/txtone.x create mode 100644 pkg/utilities/nttools/threed/x_threed.x create mode 100644 pkg/utilities/nttools/thselect.par create mode 100644 pkg/utilities/nttools/tinfo.par create mode 100644 pkg/utilities/nttools/tinfo/mkpkg create mode 100644 pkg/utilities/nttools/tinfo/tinfo.x create mode 100644 pkg/utilities/nttools/tinfo/tlcol.x create mode 100644 pkg/utilities/nttools/tintegrate.par create mode 100644 pkg/utilities/nttools/tintegrate/mkpkg create mode 100644 pkg/utilities/nttools/tintegrate/tintegrate.x create mode 100644 pkg/utilities/nttools/tjoin.par create mode 100644 pkg/utilities/nttools/tjoin/closeiotab.x create mode 100644 pkg/utilities/nttools/tjoin/dojoin.x create mode 100644 pkg/utilities/nttools/tjoin/freetol.x create mode 100644 pkg/utilities/nttools/tjoin/isnumber.x create mode 100644 pkg/utilities/nttools/tjoin/issame.x create mode 100644 pkg/utilities/nttools/tjoin/mkjoin.x create mode 100644 pkg/utilities/nttools/tjoin/mkpkg create mode 100644 pkg/utilities/nttools/tjoin/openitab.x create mode 100644 pkg/utilities/nttools/tjoin/openotab.x create mode 100644 pkg/utilities/nttools/tjoin/readtol.x create mode 100644 pkg/utilities/nttools/tjoin/removejcol.x create mode 100644 pkg/utilities/nttools/tjoin/renamecol.x create mode 100644 pkg/utilities/nttools/tjoin/spptype.x create mode 100644 pkg/utilities/nttools/tjoin/tjoin.h create mode 100644 pkg/utilities/nttools/tjoin/tjoin.x create mode 100644 pkg/utilities/nttools/tlcol.par create mode 100644 pkg/utilities/nttools/tlinear.par create mode 100644 pkg/utilities/nttools/tlinear/mkpkg create mode 100644 pkg/utilities/nttools/tlinear/tlinear.x create mode 100644 pkg/utilities/nttools/tmatch.par create mode 100644 pkg/utilities/nttools/tmatch/getmatch.x create mode 100644 pkg/utilities/nttools/tmatch/getnorm.x create mode 100644 pkg/utilities/nttools/tmatch/getweight.x create mode 100644 pkg/utilities/nttools/tmatch/infomatch.x create mode 100644 pkg/utilities/nttools/tmatch/mkpkg create mode 100644 pkg/utilities/nttools/tmatch/putmatch.x create mode 100644 pkg/utilities/nttools/tmatch/rowname.x create mode 100644 pkg/utilities/nttools/tmatch/setindex.x create mode 100644 pkg/utilities/nttools/tmatch/sortclose.x create mode 100644 pkg/utilities/nttools/tmatch/sortdist.x create mode 100644 pkg/utilities/nttools/tmatch/tmatch.x create mode 100644 pkg/utilities/nttools/tmerge.par create mode 100644 pkg/utilities/nttools/tmerge/mkpkg create mode 100644 pkg/utilities/nttools/tmerge/tmerge.x create mode 100644 pkg/utilities/nttools/tprint.par create mode 100644 pkg/utilities/nttools/tprint/mkpkg create mode 100644 pkg/utilities/nttools/tprint/notes create mode 100644 pkg/utilities/nttools/tprint/tdump.x create mode 100644 pkg/utilities/nttools/tprint/tprhtml.x create mode 100644 pkg/utilities/nttools/tprint/tprint.h create mode 100644 pkg/utilities/nttools/tprint/tprint.x create mode 100644 pkg/utilities/nttools/tprint/tprlatex.x create mode 100644 pkg/utilities/nttools/tprint/tprplain.x create mode 100644 pkg/utilities/nttools/tproduct.par create mode 100644 pkg/utilities/nttools/tproduct/mkpkg create mode 100644 pkg/utilities/nttools/tproduct/tproduct.x create mode 100644 pkg/utilities/nttools/tproject.par create mode 100644 pkg/utilities/nttools/tproject/mkpkg create mode 100644 pkg/utilities/nttools/tproject/nextuniq.x create mode 100644 pkg/utilities/nttools/tproject/tproject.x create mode 100644 pkg/utilities/nttools/tproject/wproject.x create mode 100644 pkg/utilities/nttools/tquery.par create mode 100644 pkg/utilities/nttools/tquery/doquery.x create mode 100644 pkg/utilities/nttools/tquery/mkpkg create mode 100644 pkg/utilities/nttools/tquery/tquery.x create mode 100644 pkg/utilities/nttools/tquery/wquery.x create mode 100644 pkg/utilities/nttools/tread.par create mode 100644 pkg/utilities/nttools/trebin.par create mode 100644 pkg/utilities/nttools/trebin/mkpkg create mode 100644 pkg/utilities/nttools/trebin/tnamcls.x create mode 100644 pkg/utilities/nttools/trebin/tnamgio.x create mode 100644 pkg/utilities/nttools/trebin/tnaminit.x create mode 100644 pkg/utilities/nttools/trebin/trebin.h create mode 100644 pkg/utilities/nttools/trebin/trebin.x create mode 100644 pkg/utilities/nttools/trebin/tucspl.f create mode 100644 pkg/utilities/nttools/trebin/tudcol.x create mode 100644 pkg/utilities/nttools/trebin/tugcol.x create mode 100644 pkg/utilities/nttools/trebin/tugetput.x create mode 100644 pkg/utilities/nttools/trebin/tuhunt.f create mode 100644 pkg/utilities/nttools/trebin/tuiep3.f create mode 100644 pkg/utilities/nttools/trebin/tuifit.x create mode 100644 pkg/utilities/nttools/trebin/tuinterp.x create mode 100644 pkg/utilities/nttools/trebin/tuiset.x create mode 100644 pkg/utilities/nttools/trebin/tuispl.f create mode 100644 pkg/utilities/nttools/trebin/tuival.x create mode 100644 pkg/utilities/nttools/trebin/tutrim.x create mode 100644 pkg/utilities/nttools/trebin/tuxget.x create mode 100644 pkg/utilities/nttools/tselect.par create mode 100644 pkg/utilities/nttools/tselect/mkpkg create mode 100644 pkg/utilities/nttools/tselect/subset.x create mode 100644 pkg/utilities/nttools/tselect/tselect.x create mode 100644 pkg/utilities/nttools/tsort.par create mode 100644 pkg/utilities/nttools/tsort/mkpkg create mode 100644 pkg/utilities/nttools/tsort/tblextsort.x create mode 100644 pkg/utilities/nttools/tsort/tblintsort.x create mode 100644 pkg/utilities/nttools/tsort/tblmaxrow.x create mode 100644 pkg/utilities/nttools/tsort/tsort.x create mode 100644 pkg/utilities/nttools/tstat.par create mode 100644 pkg/utilities/nttools/tstat/mkpkg create mode 100644 pkg/utilities/nttools/tstat/thistogram.h create mode 100644 pkg/utilities/nttools/tstat/thistogram.x create mode 100644 pkg/utilities/nttools/tstat/thoptions.x create mode 100644 pkg/utilities/nttools/tstat/tstat.x create mode 100644 pkg/utilities/nttools/ttranspose.par create mode 100644 pkg/utilities/nttools/ttranspose/mkpkg create mode 100644 pkg/utilities/nttools/ttranspose/ttranspose.x create mode 100644 pkg/utilities/nttools/ttranspose/ttrflip.x create mode 100644 pkg/utilities/nttools/tunits.par create mode 100644 pkg/utilities/nttools/tunits/abrev.tab create mode 100644 pkg/utilities/nttools/tunits/abrev.x create mode 100644 pkg/utilities/nttools/tunits/convertcol.x create mode 100644 pkg/utilities/nttools/tunits/factor.x create mode 100644 pkg/utilities/nttools/tunits/mkpkg create mode 100644 pkg/utilities/nttools/tunits/parseunits.com create mode 100644 pkg/utilities/nttools/tunits/parseunits.x create mode 100644 pkg/utilities/nttools/tunits/parseunits.y create mode 100644 pkg/utilities/nttools/tunits/tuniterr.x create mode 100644 pkg/utilities/nttools/tunits/tunits.h create mode 100644 pkg/utilities/nttools/tunits/tunits.x create mode 100644 pkg/utilities/nttools/tunits/unhash.x create mode 100644 pkg/utilities/nttools/tunits/units.tab create mode 100644 pkg/utilities/nttools/tunits/units.x create mode 100644 pkg/utilities/nttools/tunits/unstr.x create mode 100644 pkg/utilities/nttools/tupar.par create mode 100644 pkg/utilities/nttools/tupar/mkpkg create mode 100644 pkg/utilities/nttools/tupar/tuinstr.x create mode 100644 pkg/utilities/nttools/tupar/tupar.h create mode 100644 pkg/utilities/nttools/tupar/tupar.x create mode 100644 pkg/utilities/nttools/x_nttools.x create mode 100644 pkg/utilities/nttools/zz.xml create mode 100644 pkg/utilities/nttools/zz_bad.xml create mode 100644 pkg/utilities/nttools/zz_rewrite.xml create mode 100644 pkg/utilities/pffctn.x create mode 100644 pkg/utilities/pfregres.f create mode 100644 pkg/utilities/polyfit.par create mode 100644 pkg/utilities/split.par create mode 100644 pkg/utilities/surfit.par create mode 100644 pkg/utilities/t_curfit.x create mode 100644 pkg/utilities/t_detab.x create mode 100644 pkg/utilities/t_entab.x create mode 100644 pkg/utilities/t_lcase.x create mode 100644 pkg/utilities/t_polyfit.x create mode 100644 pkg/utilities/t_split.x create mode 100644 pkg/utilities/t_surfit.x create mode 100644 pkg/utilities/t_translit.x create mode 100644 pkg/utilities/t_ucase.x create mode 100644 pkg/utilities/t_urand.x create mode 100644 pkg/utilities/translit.par create mode 100644 pkg/utilities/ucase.par create mode 100644 pkg/utilities/urand.par create mode 100644 pkg/utilities/utilities.cl create mode 100644 pkg/utilities/utilities.hd create mode 100644 pkg/utilities/utilities.men create mode 100644 pkg/utilities/utilities.par create mode 100644 pkg/utilities/x_utilities.x (limited to 'pkg/utilities') diff --git a/pkg/utilities/README b/pkg/utilities/README new file mode 100644 index 00000000..30b531cc --- /dev/null +++ b/pkg/utilities/README @@ -0,0 +1,3 @@ +The UTILITIES package is a place to put programs which should be in the +mainline system, but which do not logically belong in any other package. +See also the NOAO.ASTUTIL package, for utilities pertaining to astronomy. diff --git a/pkg/utilities/Revisions b/pkg/utilities/Revisions new file mode 100644 index 00000000..e55b0a76 --- /dev/null +++ b/pkg/utilities/Revisions @@ -0,0 +1,178 @@ +.help revisions Jun88 pkg.utilities +.nf + +mkpkg +utilities.hd +lcase.x -> t_lcase.x +luase.x -> t_ucase.x +split.x -> t_split.x +detab.x -> t_detab.x +entab.x -> t_entab.x +doc/bases.hlp + + Renamed files, added help page for BASES task. (10/24/11) + + +======= +V2.12.2 +======= + +utilities$urand.x + Modified method based on clktime for generating a new seed when + the users specifies it as INDEF so that it doesn't have a 1 second + granularity. (8/7/03, Valdes) + +===== +V2.12 +===== + +utilities$mkpkg + Added missing dependencies. (10/11/99, Valdes) + +utilities$curfit.gx +utilities$curfit.x + Removed an unneccessay include file statmenet. (9/22/99, Davis) + +======= +V2.11.2 +======= + +utilities$surfit.par +utilities$t_surfit.x +utilities$doc/surfit.hlp + Added support for the half cross-terms option to the surfit task. This + involved changing the type of the xterms parameter from boolen (yes/no) + to string (none,half,full) but involved no other interface changes. + (7/6/99, Davis) + +utilities$doc/surfit.hlp + Fixed minor formating problem. (4/22/99, Valdes) + +======= +V2.11.1 +======= + +utilities$urand.x +utilities$doc/urand.hlp + If the "seed" parameter is set to INDEF then the clock time (integer + seconds since 1980) will be used as the seed. This allows different + executions to produce different random numbers. + (9/23/97, Valdes) + +=========== +V2.11export +=========== + +utilities$curfit.gx + Removed repeated output and added a comment character to the table + header line. (2/29/95, Valdes) + +utilities$t_polyfit.x + Revoved the dependent variable normalization which was not doing anything + to improve the numerical statbility of the routine and which was causing + problems in the computation of the reduced chi-squared and standard + deviation statistics. + (7/11/94 LED) + +utilities$t_polyfit.x +utilities$pfregres.f + Added a trap for rmul values < 0.0 and > 1.0 to the polyfit routine + to avoid floating operand errors caused by trying to take the square + route of a negative number. + (6/20/94 LED) + +utilities$curfit.gx + Removed the graph limit setting so that the graph will be automatically + drawn with the default buffer distance from the end of the data. + Previously the end datapoints would fall right on the axes. + (5/10/94, Valdes) + +utilities$t_surfit.x + +utilities$surfit.par + +utilities$doc/surfit.hlp + +utilities$x_utilities.x +utilities$mkpkg +utilities$utilities.cl +utilities$utilities.men +utilities$utilities.hd + A task for fitting a 2D function or "surface" to an irregularly + sampled set of x, y, and z points has been added. (7/6/93, Valdes) + +utilities$curfit/t_curfit.x,curfit.gx + Curfit was failing if the input file list contained more than one + file or image. The problem was that ic_open was being called + before the file loop but ic_close(rd) was being called after every + fit leaving a null pointer in place for the second file. + (7/30/90 LED) + +utilities$doc/polyfit.hlp + Added the missing "statistical" heading under the weighting section. + (7/23/90 LED) + +utilities$lcase.x + Changed the default output file name extension from ".uc" to ".lc". + (3/7/90 LED) + +utilities$t_curfit.x + For list input only, curfit now sorts the input array before fitting. + Sorted data is required by the rg_ranges procedure (even in the + default case of sample=*) or else data points will be ommitted from + the fit. (24/6/88 ShJ) + +utilities$t_curfit.x,curfit.gx + Davis, December 2, 1987 + 1. Added a new parameter weighting to the curfit task. The four weighting + options are uniform, user, statistical and instrumental. The weights in + the four cases are 1.0, user input, 1/y and 1/sigmay ** 2. In the latter + case the weight that the user supplies is interpreted as sigmay. All + four options are available if input is from a list or STDIN. If input + is from an image section only the uniform and statistical options are + available. + +utilities$t_polyfit.x + Davis, November 23, 1987. + 1. Added a new parameter weighting to the polyfit task. The three + weighting options are instrumental, uniform and statistical. The + weights in the three cases are 1./sigy ** 2, 1.0 and 1/y consistent + with the Bevington definitions. If the weighting is instrumental + the user must supply the error in y as well as x and y. + +utilities$*x + Valdes, February 17, 1987 + 1. Required GIO changes. + +utilities$t_curfit.x, curfit.gx: Valdes, July 3, 1986 + 1. Modified CURFIT to use new ICFIT package. + +________________________________________ + +From: Valdes Mar 14, 1986 +Task: Curfit + +1. The CURFIT task has been modified to allow switching between single +and double precision calculations. Generally double precision is used +but this task provides a convenient test facility for testing changes +in the mathematical routines or which precision is appropriate for a +new task being developed. + +2. The help page was updated. + +________________________________________ + +From: Hammond Jan 6, 1986 +Task: Curfit + +1. A new task, Curfit, has been installed. It is the cl interface to + the curfit package and allows for interactive fitting of functions + to list or image data. The function types supported are Legendre + or Chebyshev polynomials and linear or cubic splines. + +__________________________________________ + +From: Hammond Dec 19, 1985 +Task: Polyfit + +1. Polyfit no longer gets a floating divide by zero when a linear fit + has a correlation = 1. The problem was in the error calculation (ftest) + portion of the Bevington routine regres. This problem was reported + by ST. +.endhelp diff --git a/pkg/utilities/bases.cl b/pkg/utilities/bases.cl new file mode 100644 index 00000000..fa2c12ea --- /dev/null +++ b/pkg/utilities/bases.cl @@ -0,0 +1,87 @@ +procedure bases (i) + +int i {prompt="Integer for base conversion"} + +string nbyte = "0" {prompt="Number of bytes of precision", enum="0|1|2|4"} +bool verbose = yes {prompt="Print labels for the columns?"} + +begin + int ii, ui, nibble[8], nnibble, nn, ndigits, index + bool is_negative, is_byte, is_short, is_ascii, is_ubyte, is_ushort + + ii = i + + is_negative = (ii < 0) + + is_ascii = (ii <= 07fx && ! is_negative) + is_ubyte = (ii < 100x && ii >= -100x) + is_ushort = (ii < 10000x && ii >= -10000x) + + is_byte = (abs(ii) <= 07fx) + is_short = (abs(ii) <= 07fffx) + + if (nbyte == "0") { + if (is_ubyte || is_byte) + nnibble = 2 + else if (is_ushort || is_short) + nnibble = 4 + else + nnibble = 8 + } else if (nbyte == "1") { + nnibble = 2 + } else if (nbyte == "2") { + nnibble = 4 + } else if (nbyte == "4") { + nnibble = 8 + } + + # explicitly convert to 2's complement for the bytes or shorts + ui = ii +# if (is_negative && nnibble != 8) { + if (is_negative) { + ndigits = 4*nnibble - 1 + ui = 2**ndigits + 2**ndigits - abs(ii) + } + + nn = ui + for (index=nnibble; index>=1; index-=1) { + nibble[index] = max (0x, min ( 0ffx, mod(nn,10x))) + nn = nn / 10x + } + + if (verbose) { + if (nnibble == 2) + printf (" dec hex oct ") + else if (nnibble == 4) + printf (" dec hex octal ") + else + printf (" dec hex octal ") + + for (index=1; index<=(nnibble/2); index+=1) + printf (" 7654 3210") + + if (is_negative) + printf (" unsigned") + else if (is_ascii) + printf (" ascii") + + printf ("\n") + } + + if (nnibble == 2) + printf ("%4d %02xx %03ob ", ii, ui, ui) + else if (nnibble == 4) + printf ("%6d %04xx %06ob ", ii, ui, ui) + else + printf ("%11d %08xx %011ob ", ii, ui, ui) + + for (index=1; index<=nnibble; index+=1) + printf (" %04r2", nibble[index]) + + if (is_negative) + printf (" %d", ui) + else if (is_ascii) + printf (" %3c", ii) + + printf ("\n") +end diff --git a/pkg/utilities/curfit.gx b/pkg/utilities/curfit.gx new file mode 100644 index 00000000..588bc1d1 --- /dev/null +++ b/pkg/utilities/curfit.gx @@ -0,0 +1,216 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "curfit.h" + +define VERBOSE_OUTPUT 1 +define LIST_OUTPUT 2 +define DEFAULT_OUTPUT 3 + +define CF_UNIFORM 1 +define CF_USER 2 +define CF_STATISTICAL 3 +define CF_INSTRUMENTAL 4 + +# CF_FIT -- Called once for each curve to be fit. + +$for (rd) +procedure cf_fit$t (ic, gt, x, y, wts, nvalues, nmax, device, interactive, ofmt, + power) + +pointer ic # ICFIT pointer +pointer gt # Graphics tools pointer +PIXEL x[nmax] # X data values +PIXEL y[nmax] # Y data values +PIXEL wts[nmax] # Weights +int nvalues # Number of data points +int nmax # Maximum number of data points +char device[SZ_FNAME] # Output graphics device +int interactive # Fit curve interactively? +int ofmt # Type of output listing +bool power # Convert coeff to power series? + +int ncoeff, i +PIXEL xmin, xmax +pointer sp, gp, cv, coeff, tty +pointer gopen(), ttyodes() +int fstati(), $tcvstati() + +begin + # Determine data range and set up curve fitting limits. + call alim$t (x, nvalues, xmin, xmax) + call ic_putr (ic, "xmin", real (xmin)) + call ic_putr (ic, "xmax", real (xmax)) + + if (interactive == YES) { + gp = gopen (device, NEW_FILE, STDGRAPH) + call icg_fit$t (ic, gp, "cursor", gt, cv, x, y, wts, nvalues) + call gclose (gp) + } else + # Do fit non-interactively + call ic_fit$t (ic, cv, x, y, wts, nvalues, YES, YES, YES, YES) + + # Output answers to STDOUT + if (ofmt != LIST_OUTPUT) { + if (fstati (STDOUT, F_REDIR) == NO) { + tty = ttyodes ("terminal") + call ttyclear (STDOUT, tty) + call ttycdes (tty) + } + + #call ic_show (ic, "STDOUT", gt) + call ic_vshow$t (ic, "STDOUT", cv, x, y, wts, nvalues, gt) + + if (ofmt == VERBOSE_OUTPUT) { + call printf ( + "\n# \t X \t Yc \t Y \t W\n") + call cf_listxy$t (cv, x, y, wts, nvalues) + } + } else + call cf_listxy$t (cv, x, y, wts, nvalues) + + # Convert coefficients if requested for legendre or chebyshev + if (power && ofmt != LIST_OUTPUT) { + # Calculate and print coefficients + ncoeff = $tcvstati (cv, CVNCOEFF) + call smark (sp) + call salloc (coeff, ncoeff, TY_PIXEL) + call $tcvpower (cv, Mem$t[coeff], ncoeff) + call printf ("# Power series coefficients would be:\n") + call printf ("# \t\tcoefficient\n") + do i = 1, ncoeff { + call printf ("# \t%d \t%14.7e\n") + call pargi (i) + call parg$t (Mem$t[coeff+i-1]) + } + call sfree (sp) + } + +$if (datatype == r) + call cvfree (cv) +$else + call $tcvfree (cv) +$endif + #call ic_close$t (ic) +end + + +# CF_LISTXY -- Print answers to STDOUT as x,y pairs. + +procedure cf_listxy$t (cv, xvals, yvals, wts, nvalues) + +pointer cv # Pointer to curfit structure +int nvalues # Number of data values +PIXEL xvals[nvalues] # Array of x data values +PIXEL yvals[nvalues] # Array of y data values +PIXEL wts[nvalues] # Array of weights + +int i +PIXEL $tcveval() + +begin + do i = 1, nvalues { + call printf ("\t%14.7e \t%14.7e \t%14.7e \t%14.7e\n") + call parg$t (xvals[i]) + call parg$t ($tcveval (cv, xvals[i])) + call parg$t (yvals[i]) + call parg$t (wts[i]) + } +end + +# IM_PROJECTION -- Given an image section of arbitrary dimension, compute +# the projection along a single axis by taking the average over the other +# axes. We do not know about bad pixels. + +procedure im_projection$t (im, x, y, w, npix, weighting, axis) + +pointer im # Pointer to image header structure +PIXEL x[npix] # Index of projection vector +PIXEL y[npix] # Receives the projection vector +PIXEL w[npix] # Receives the weight vector +int weighting # Weighting of the individual points +int npix # Length of projection vector +int axis # The axis to be projected to (x=1) + +int i, lastv +long v[IM_MAXDIM], nsum, totpix +pointer pix +PIXEL asum$t() +pointer imgnl$t() +errchk imgnl$t + +begin + if (im == NULL) + call error (1, "Image projection operator called with null im") + if (axis < 1 || axis > IM_NDIM(im)) + call error (2, "Attempt to take projection over nonexistent axis") + + + # Set the y projection vector + call aclr$t (y, npix) + call amovkl (long(1), v, IM_MAXDIM) + + switch (axis) { + case 1: + # Since the image is read line by line, it is easy to compute the + # projection along the x-axis (axis 1). We merely sum all of the + # image lines. + + while (imgnl$t (im, pix, v) != EOF) + call aadd$t (Mem$t[pix], y, y, npix) + + default: + # Projecting along any other axis when reading the image line + # by line is a bit difficult to understand. Basically, the + # element 'axis' of the V vector (position of the line in the + # image) gives us the index into the appropriate element of + # y. When computing the projection over multiple dimensions, + # the same output element will be referenced repeatedly. All + # of the elmenents of the input line are summed and added into + # this output element. + + for (lastv=v[axis]; imgnl$t (im, pix, v) != EOF; lastv=v[axis]) { + i = lastv + if (i <= npix) + y[i] = y[i] + asum$t (Mem$t[pix], IM_LEN(im,1)) + } + } + + # Now compute the number of pixels contributing to each element + # of the output vector. This is the number of pixels in the image + # divided by the length of the projection. + + totpix = 1 + do i = 1, IM_NDIM(im) + if (i == axis) + totpix = totpix * min (npix, IM_LEN(im,i)) + else + totpix = totpix * IM_LEN(im,i) + nsum = totpix / min (npix, IM_LEN(im,axis)) + + # Compute the average by dividing by the number if pixels summed at + # each point. + call adivk$t (y, PIXEL (nsum), y, npix) + + # Set the x and weight vectors + do i = 1, npix { + x[i] = i + switch (weighting) { + case CF_STATISTICAL: + if (y[i] > 0.0) + w[i] = 1.0 / y[i] + else if (y[i] < 0.0) + w[i] = abs (1.0 / y[i]) + else + w[i] = 1.0 + case CF_UNIFORM: + w[i] = 1. + default: + w[i] = 1. + } + } +end +$endfor diff --git a/pkg/utilities/curfit.h b/pkg/utilities/curfit.h new file mode 100644 index 00000000..85fcb840 --- /dev/null +++ b/pkg/utilities/curfit.h @@ -0,0 +1,19 @@ +# NAMES -- Map generic names to external names. + +define ic_fitr ic_fit +define icg_fitr icg_fit +define ic_freer ic_free +define ic_errorsr ic_errors + +define rcvcoeff cvcoeff +define rcverrors cverrors +define rcveval cveval +define rcvfit cvfit +define rcvfree cvfree +define rcvinit cvinit +define rcvpower cvpower +define rcvrefit cvrefit +define rcvrject cvrject +define rcvsolve cvsolve +define rcvstati cvstati +define rcvvector cvvector diff --git a/pkg/utilities/curfit.par b/pkg/utilities/curfit.par new file mode 100644 index 00000000..2e1ebe02 --- /dev/null +++ b/pkg/utilities/curfit.par @@ -0,0 +1,12 @@ +input,f,a,,,,input list of files or images +function,s,h,legendre,,,type of function to fit +weighting,s,h,uniform,,,'Weighting (uniform,user,statistical,instrumental)' +order,i,h,4,,,order of the fit +interactive,b,h,yes,,,interactively tweak fit parameters? +axis,i,h,1,,,projection axis if input is an image +listdata,b,h,no,,,two column output list? +verbose,b,h,no,,,lengthy output format? +calctype,s,h,"double","|real|double|",,Calculation datatype +power,b,h,no,,,convert coeffecients to power series? +device,s,h,"stdgraph",,,name of interactive plotting device +cursor,*gcur,h,"",,,Graphics cursor input diff --git a/pkg/utilities/curfit.x b/pkg/utilities/curfit.x new file mode 100644 index 00000000..eb79959c --- /dev/null +++ b/pkg/utilities/curfit.x @@ -0,0 +1,404 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "curfit.h" + +define VERBOSE_OUTPUT 1 +define LIST_OUTPUT 2 +define DEFAULT_OUTPUT 3 + +define CF_UNIFORM 1 +define CF_USER 2 +define CF_STATISTICAL 3 +define CF_INSTRUMENTAL 4 + +# CF_FIT -- Called once for each curve to be fit. + + +procedure cf_fitr (ic, gt, x, y, wts, nvalues, nmax, device, interactive, ofmt, + power) + +pointer ic # ICFIT pointer +pointer gt # Graphics tools pointer +real x[nmax] # X data values +real y[nmax] # Y data values +real wts[nmax] # Weights +int nvalues # Number of data points +int nmax # Maximum number of data points +char device[SZ_FNAME] # Output graphics device +int interactive # Fit curve interactively? +int ofmt # Type of output listing +bool power # Convert coeff to power series? + +int ncoeff, i +real xmin, xmax +pointer sp, gp, cv, coeff, tty +pointer gopen(), ttyodes() +int fstati(), rcvstati() + +begin + # Determine data range and set up curve fitting limits. + call alimr (x, nvalues, xmin, xmax) + call ic_putr (ic, "xmin", real (xmin)) + call ic_putr (ic, "xmax", real (xmax)) + + if (interactive == YES) { + gp = gopen (device, NEW_FILE, STDGRAPH) + call icg_fitr (ic, gp, "cursor", gt, cv, x, y, wts, nvalues) + call gclose (gp) + } else + # Do fit non-interactively + call ic_fitr (ic, cv, x, y, wts, nvalues, YES, YES, YES, YES) + + # Output answers to STDOUT + if (ofmt != LIST_OUTPUT) { + if (fstati (STDOUT, F_REDIR) == NO) { + tty = ttyodes ("terminal") + call ttyclear (STDOUT, tty) + call ttycdes (tty) + } + + #call ic_show (ic, "STDOUT", gt) + call ic_vshowr (ic, "STDOUT", cv, x, y, wts, nvalues, gt) + + if (ofmt == VERBOSE_OUTPUT) { + call printf ( + "\n# \t X \t Yc \t Y \t W\n") + call cf_listxyr (cv, x, y, wts, nvalues) + } + } else + call cf_listxyr (cv, x, y, wts, nvalues) + + # Convert coefficients if requested for legendre or chebyshev + if (power && ofmt != LIST_OUTPUT) { + # Calculate and print coefficients + ncoeff = rcvstati (cv, CVNCOEFF) + call smark (sp) + call salloc (coeff, ncoeff, TY_REAL) + call rcvpower (cv, Memr[coeff], ncoeff) + call printf ("# Power series coefficients would be:\n") + call printf ("# \t\tcoefficient\n") + do i = 1, ncoeff { + call printf ("# \t%d \t%14.7e\n") + call pargi (i) + call pargr (Memr[coeff+i-1]) + } + call sfree (sp) + } + + call cvfree (cv) + #call ic_close$t (ic) +end + + +# CF_LISTXY -- Print answers to STDOUT as x,y pairs. + +procedure cf_listxyr (cv, xvals, yvals, wts, nvalues) + +pointer cv # Pointer to curfit structure +int nvalues # Number of data values +real xvals[nvalues] # Array of x data values +real yvals[nvalues] # Array of y data values +real wts[nvalues] # Array of weights + +int i +real rcveval() + +begin + do i = 1, nvalues { + call printf ("\t%14.7e \t%14.7e \t%14.7e \t%14.7e\n") + call pargr (xvals[i]) + call pargr (rcveval (cv, xvals[i])) + call pargr (yvals[i]) + call pargr (wts[i]) + } +end + +# IM_PROJECTION -- Given an image section of arbitrary dimension, compute +# the projection along a single axis by taking the average over the other +# axes. We do not know about bad pixels. + +procedure im_projectionr (im, x, y, w, npix, weighting, axis) + +pointer im # Pointer to image header structure +real x[npix] # Index of projection vector +real y[npix] # Receives the projection vector +real w[npix] # Receives the weight vector +int weighting # Weighting of the individual points +int npix # Length of projection vector +int axis # The axis to be projected to (x=1) + +int i, lastv +long v[IM_MAXDIM], nsum, totpix +pointer pix +real asumr() +pointer imgnlr() +errchk imgnlr + +begin + if (im == NULL) + call error (1, "Image projection operator called with null im") + if (axis < 1 || axis > IM_NDIM(im)) + call error (2, "Attempt to take projection over nonexistent axis") + + + # Set the y projection vector + call aclrr (y, npix) + call amovkl (long(1), v, IM_MAXDIM) + + switch (axis) { + case 1: + # Since the image is read line by line, it is easy to compute the + # projection along the x-axis (axis 1). We merely sum all of the + # image lines. + + while (imgnlr (im, pix, v) != EOF) + call aaddr (Memr[pix], y, y, npix) + + default: + # Projecting along any other axis when reading the image line + # by line is a bit difficult to understand. Basically, the + # element 'axis' of the V vector (position of the line in the + # image) gives us the index into the appropriate element of + # y. When computing the projection over multiple dimensions, + # the same output element will be referenced repeatedly. All + # of the elmenents of the input line are summed and added into + # this output element. + + for (lastv=v[axis]; imgnlr (im, pix, v) != EOF; lastv=v[axis]) { + i = lastv + if (i <= npix) + y[i] = y[i] + asumr (Memr[pix], IM_LEN(im,1)) + } + } + + # Now compute the number of pixels contributing to each element + # of the output vector. This is the number of pixels in the image + # divided by the length of the projection. + + totpix = 1 + do i = 1, IM_NDIM(im) + if (i == axis) + totpix = totpix * min (npix, IM_LEN(im,i)) + else + totpix = totpix * IM_LEN(im,i) + nsum = totpix / min (npix, IM_LEN(im,axis)) + + # Compute the average by dividing by the number if pixels summed at + # each point. + call adivkr (y, real (nsum), y, npix) + + # Set the x and weight vectors + do i = 1, npix { + x[i] = i + switch (weighting) { + case CF_STATISTICAL: + if (y[i] > 0.0) + w[i] = 1.0 / y[i] + else if (y[i] < 0.0) + w[i] = abs (1.0 / y[i]) + else + w[i] = 1.0 + case CF_UNIFORM: + w[i] = 1. + default: + w[i] = 1. + } + } +end + +procedure cf_fitd (ic, gt, x, y, wts, nvalues, nmax, device, interactive, ofmt, + power) + +pointer ic # ICFIT pointer +pointer gt # Graphics tools pointer +double x[nmax] # X data values +double y[nmax] # Y data values +double wts[nmax] # Weights +int nvalues # Number of data points +int nmax # Maximum number of data points +char device[SZ_FNAME] # Output graphics device +int interactive # Fit curve interactively? +int ofmt # Type of output listing +bool power # Convert coeff to power series? + +int ncoeff, i +double xmin, xmax +pointer sp, gp, cv, coeff, tty +pointer gopen(), ttyodes() +int fstati(), dcvstati() + +begin + # Determine data range and set up curve fitting limits. + call alimd (x, nvalues, xmin, xmax) + call ic_putr (ic, "xmin", real (xmin)) + call ic_putr (ic, "xmax", real (xmax)) + + if (interactive == YES) { + gp = gopen (device, NEW_FILE, STDGRAPH) + call icg_fitd (ic, gp, "cursor", gt, cv, x, y, wts, nvalues) + call gclose (gp) + } else + # Do fit non-interactively + call ic_fitd (ic, cv, x, y, wts, nvalues, YES, YES, YES, YES) + + # Output answers to STDOUT + if (ofmt != LIST_OUTPUT) { + if (fstati (STDOUT, F_REDIR) == NO) { + tty = ttyodes ("terminal") + call ttyclear (STDOUT, tty) + call ttycdes (tty) + } + + #call ic_show (ic, "STDOUT", gt) + call ic_vshowd (ic, "STDOUT", cv, x, y, wts, nvalues, gt) + + if (ofmt == VERBOSE_OUTPUT) { + call printf ( + "\n# \t X \t Yc \t Y \t W\n") + call cf_listxyd (cv, x, y, wts, nvalues) + } + } else + call cf_listxyd (cv, x, y, wts, nvalues) + + # Convert coefficients if requested for legendre or chebyshev + if (power && ofmt != LIST_OUTPUT) { + # Calculate and print coefficients + ncoeff = dcvstati (cv, CVNCOEFF) + call smark (sp) + call salloc (coeff, ncoeff, TY_DOUBLE) + call dcvpower (cv, Memd[coeff], ncoeff) + call printf ("# Power series coefficients would be:\n") + call printf ("# \t\tcoefficient\n") + do i = 1, ncoeff { + call printf ("# \t%d \t%14.7e\n") + call pargi (i) + call pargd (Memd[coeff+i-1]) + } + call sfree (sp) + } + + call dcvfree (cv) + #call ic_close$t (ic) +end + + +# CF_LISTXY -- Print answers to STDOUT as x,y pairs. + +procedure cf_listxyd (cv, xvals, yvals, wts, nvalues) + +pointer cv # Pointer to curfit structure +int nvalues # Number of data values +double xvals[nvalues] # Array of x data values +double yvals[nvalues] # Array of y data values +double wts[nvalues] # Array of weights + +int i +double dcveval() + +begin + do i = 1, nvalues { + call printf ("\t%14.7e \t%14.7e \t%14.7e \t%14.7e\n") + call pargd (xvals[i]) + call pargd (dcveval (cv, xvals[i])) + call pargd (yvals[i]) + call pargd (wts[i]) + } +end + +# IM_PROJECTION -- Given an image section of arbitrary dimension, compute +# the projection along a single axis by taking the average over the other +# axes. We do not know about bad pixels. + +procedure im_projectiond (im, x, y, w, npix, weighting, axis) + +pointer im # Pointer to image header structure +double x[npix] # Index of projection vector +double y[npix] # Receives the projection vector +double w[npix] # Receives the weight vector +int weighting # Weighting of the individual points +int npix # Length of projection vector +int axis # The axis to be projected to (x=1) + +int i, lastv +long v[IM_MAXDIM], nsum, totpix +pointer pix +double asumd() +pointer imgnld() +errchk imgnld + +begin + if (im == NULL) + call error (1, "Image projection operator called with null im") + if (axis < 1 || axis > IM_NDIM(im)) + call error (2, "Attempt to take projection over nonexistent axis") + + + # Set the y projection vector + call aclrd (y, npix) + call amovkl (long(1), v, IM_MAXDIM) + + switch (axis) { + case 1: + # Since the image is read line by line, it is easy to compute the + # projection along the x-axis (axis 1). We merely sum all of the + # image lines. + + while (imgnld (im, pix, v) != EOF) + call aaddd (Memd[pix], y, y, npix) + + default: + # Projecting along any other axis when reading the image line + # by line is a bit difficult to understand. Basically, the + # element 'axis' of the V vector (position of the line in the + # image) gives us the index into the appropriate element of + # y. When computing the projection over multiple dimensions, + # the same output element will be referenced repeatedly. All + # of the elmenents of the input line are summed and added into + # this output element. + + for (lastv=v[axis]; imgnld (im, pix, v) != EOF; lastv=v[axis]) { + i = lastv + if (i <= npix) + y[i] = y[i] + asumd (Memd[pix], IM_LEN(im,1)) + } + } + + # Now compute the number of pixels contributing to each element + # of the output vector. This is the number of pixels in the image + # divided by the length of the projection. + + totpix = 1 + do i = 1, IM_NDIM(im) + if (i == axis) + totpix = totpix * min (npix, IM_LEN(im,i)) + else + totpix = totpix * IM_LEN(im,i) + nsum = totpix / min (npix, IM_LEN(im,axis)) + + # Compute the average by dividing by the number if pixels summed at + # each point. + call adivkd (y, double (nsum), y, npix) + + # Set the x and weight vectors + do i = 1, npix { + x[i] = i + switch (weighting) { + case CF_STATISTICAL: + if (y[i] > 0.0) + w[i] = 1.0 / y[i] + else if (y[i] < 0.0) + w[i] = abs (1.0 / y[i]) + else + w[i] = 1.0 + case CF_UNIFORM: + w[i] = 1. + default: + w[i] = 1. + } + } +end + diff --git a/pkg/utilities/decod_tablst.x b/pkg/utilities/decod_tablst.x new file mode 100644 index 00000000..16fb9c44 --- /dev/null +++ b/pkg/utilities/decod_tablst.x @@ -0,0 +1,104 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define DEFAULT_FSTSTOP 1 +define DEFAULT_TABSIZE 8 + +# DECODE_TABLIST -- Procedure to decode a string containing a list of +# tabstops into an integer array of tabs. A tabstop is indicated by +# YES. The string may be blank in which case the default +# tabsize is 8, a series of 1,2 or more arguments separated by blanks +# and/or commas, or two arguments of the form m +n where m specifies +# the first tabstop and n the tabsize. + +int procedure decode_tablist (tab_list, tabs, maxtabs) + +char tab_list[ARB] +int tabs[ARB] +int maxtabs + +bool noarg, plusarg +int ip, tp, narg, first_tabstop, tabsize, tabstop + +int decode_tabstop(), strlen(), stridxs(), ctoi() + +errchk decode_tabstop, gstrsettab + +begin + ip = 1 + + for (tp = 1; tp <= maxtabs; tp = tp+1) + tabs[tp] = NO + + noarg = true + plusarg = false + + if (strlen (tab_list) != 0) + noarg = false + if (stridxs ("+", tab_list) != 0) + plusarg = true + + for (narg = 1; narg <= maxtabs; narg = narg + 1) { + + while (IS_WHITE(tab_list[ip]) || tab_list[ip] == ',') + ip = ip + 1 + + if (tab_list[ip] == EOS) + if (noarg) { + first_tabstop = DEFAULT_FSTSTOP + tabsize = DEFAULT_TABSIZE + break + } else + return (OK) + + if (plusarg) { + + if (narg == 1) { + if (decode_tabstop (tab_list, ip, tabs, maxtabs, + first_tabstop) == ERR) + return (ERR) + } else if (narg == 2) { + ip = ip + 1 + if (ctoi (tab_list, ip, tabsize) == 0) + return (ERR) + else + break + } else + return (ERR) + + } else if (decode_tabstop (tab_list, ip, tabs, maxtabs, + tabstop) == ERR) { + + return (ERR) + } + } + + if (noarg || plusarg) + call gstrsettab (tabs, maxtabs, first_tabstop, tabsize) + + return (OK) +end + + +# DECODE_TABSTOP -- Procedure to decode tabstops + +int procedure decode_tabstop (tab_list, ip, tabs, maxtabs, tabstop) + +char tab_list[ARB] +int maxtabs +int ip +int tabs[ARB] +int tabstop + +int ctoi() + +begin + if (ctoi (tab_list, ip, tabstop) == 0) + return (ERR) + else if (tabstop <= maxtabs) { + tabs[tabstop] = YES + return (OK) + } else + return (ERR) +end diff --git a/pkg/utilities/detab.par b/pkg/utilities/detab.par new file mode 100644 index 00000000..9dbb136c --- /dev/null +++ b/pkg/utilities/detab.par @@ -0,0 +1,2 @@ +files,s,a,,,,list of files to be detabbed +tablist,s,h,"9 +8",,,list of tab stops diff --git a/pkg/utilities/doc/bases.hlp b/pkg/utilities/doc/bases.hlp new file mode 100644 index 00000000..01f822ef --- /dev/null +++ b/pkg/utilities/doc/bases.hlp @@ -0,0 +1,43 @@ +.help bases Jan85 utilities +.ih +NAME +bases -- Convert an integer to hex, octal, and binary +.ih +USAGE +bases i +.ih +PARAMETERS +.ls i +Integer for base conversion. +.le +.ls nbyte = 0 +Number of bytes of precision. Allowed values are "0", "1", "2", or "4". +.le +.ls verbose = yes +Print labels for columns? +.le +.ih +DESCRIPTION +The BASES task converts an input integer value to equivalent values in +other base systems. +.ih +EXAMPLES +1. Convert the number 256 (in various bases). Note the 'x' and 'b' suffix +appended to the value to change the input base value: + +.nf + ecl> bases 256 # decimal input + dec hex octal 7654 3210 7654 3210 + 256 0100x 000400b 0000 0001 0000 0000 + ecl> bases 256x # hex input + dec hex octal 7654 3210 7654 3210 + 598 0256x 001126b 0000 0010 0101 0110 + ecl> bases 256b # octal input + dec hex oct 7654 3210 + 174 AEx 256b 1010 1110 + +.fi + +.ih +SEE ALSO +.endhelp diff --git a/pkg/utilities/doc/curfit.hlp b/pkg/utilities/doc/curfit.hlp new file mode 100644 index 00000000..df8be6fd --- /dev/null +++ b/pkg/utilities/doc/curfit.hlp @@ -0,0 +1,168 @@ +.help curfit Jun88 utilities +.ih +NAME +curfit -- fit a curve to a list or an image section +.ih +USAGE +curfit input +.ih +PARAMETERS +.ls input +The data to be fit. May be an image section, STDIN or a list of file names. +.le +.ls function = legendre +The type of function with which to fit the data. Choices are +legendre, chebyshev, spline1 (linear spline) or spline3 (cubic spline). +.le +.ls order = 4 +The order of the fit or number of spline pieces. +.le +.ls weighting = uniform +The type of weighting for the fit. The options are: +.ls uniform +The weight w = 1.0. This option may be used for both list input and image +input. +.le +.ls user +The weights are supplied by the user. This option may be used for list input +only. +.le +.ls statistical +The weight w = 1.0 / y. This option can be used for both list and image data. +.le +.ls instrumental +The user supplies the sigmay for each point and w = 1.0 / sigmay ** 2. +This option may be used for list input only. +.le +.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 axis = 1 +If \fBinput\fR names an image or image section, this parameter specifies +the axis along which the image is projected for fitting. +.le +.ls listdata = no +If \fBlistdata\fR is set to yes, the only printed output will be the calculated +values for the X,Y pairs. This is useful as input to \fIgraph\fR or some +other list oriented program. +.le +.ls verbose = no +If \fBverbose\fR is set to yes, the fitted (X,Y) pairs are listed in addition +to the default output of filename, function type, order, rejection parameters, +coefficients and their errors. +.le +.ls power = no +If \fBpower\fR is set to yes, the coefficients of the legendre or +chebyshev polynomials will be converted to power series coefficients. +.le +.ls calctype = "double" +Calculation datatype. The two datatypes are "real" (single precision) and +"double" (double precision). +.le +.ls device = "stdgraph" +The output device for interactive graphics. +.le +.ls cursor = "stdgcur" +The source of graphics cursor input. +.le +.ih +DESCRIPTION +A curve is fit to data read from either an image section or a list. +The type of curve is set by the \fBfunction\fR parameter as either +a legendre polynomial, chebyshev polynomial, linear spline or cubic +spline, with the order of the fit (or number of spline pieces) set by +\fBorder\fR. If data is read from an image, the \fBaxis\fR parameter +is used to reduce the dimensionality of the image; it specifies the +axis along which the image is projected. For example, when \fBaxis\fR += 1, the image is compressed to a column. \fBAxis\fR = 2 would project +the image along a line; \fBaxis\fR = 3 indicates projection in the z +direction, etc. + +The input data must be ordered in x because of a restriction in the +interactive plotting package. If the input is from a list, the data +are sorted prior to fitting; image input data are assumed to be ordered +in x and are not explicitly sorted by \fIcurfit\fR. + +If the input is from a list the user may specify a set of weights, +\fBweighting\fR = user or a set of errors, \fBweighting\fR = +instrumental. An additional weighting option \fBweighting\fR = statistical +can be used for both list and image data. The default is \fBweighting\fR = +uniform. + +When \fBinteractive\fR = yes, the curve is plotted and cursor commands allow +for interactive examining and adjustment of the fit. +The full range of interactive cursor commands is available +including those for changing the function type, order, and rejection criteria, +and examining the residuals. + +The final fit parameters are written to STDOUT with the +format controlled by parameters \fBverbose\fR and \fBlistdata\fR. +By default, the function type, order, and resulting chi-square are +printed as well as the coefficients and their standard deviations. +If \fBverbose\fR is set to yes, a list of X, Y_calculated, Y_input, +and W_input is also printed. +If \fBlistdata\fR is set to yes, the only printed output will +be a listing of X, Yc, Y and W. This provides a list suitable as input to +\fBgraph\fR or any other list oriented utility. Setting \fBlistdata\fR +to yes overrides the verbose option. + +When \fBpower\fR = yes, the coefficients are converted to power series +coefficients of the form a0 + a1*X + a2*X**2 +a3*X**3 .... +Only legendre and chebyshev coefficients are converted; a conversion +of spline coefficients is meaningless. Also, errors in the coefficients +are not converted. + +The user has a choice of single or double precision calculations. Generally +double precisions is used since the calculation time is only slightly +longer. The single precision calculation is used in many other tasks +which do many fits. This task provides a test tool to compare the +results between the two levels of precision. +.ih +EXAMPLES + +1. The x,y pairs in file test.data are interactively fit with a fourth +order legendre polynomial. The printed output is shown. + + cl> curfit test.data + +.nf + NOAO/IRAF V2.0 Hammond@lyra Fri 11:45:41 13-Dec-85 + file = test.data + function = legendre + grow = 0. + naverage = 1 + order = 4 + low_reject = 0., high_reject = 0. + niterate = 1 + sample = * + total points = 8 + sample points = 8 + nrejected = 0 + deleted = 0 + square root of reduced chi square = 3.008706E-6 + coefficient error + 1 2.633E1 1.098E-6 + 2 3.150E1 1.820E-6 + 3 8.167E0 1.896E-6 + 4 -1.621E-6 2.117E-6 + +.fi +2. Fit a cubic spline to the last 12 columns of image "m74". + + cl> curfit m74[501:512,1:512] axis=2 func=spline3 order=5 + +3. Use \fIcurfit\fR as a filter to overplot a smoothed curve to an existing +plot of the data points. The command line for \fBgraph\fR is shown as +well as the \fBcurfit\fR command. Note the interactive flag for +\fBcurfit\fR is turned off. + + cl> graph points.list point+ mark=box wx1=.13 xlab="X VALUES"\ + >>> ylab="Y VALUES" title="Legendre fit to points.list" + + cl> type points.list | curfit list+ inter- | graph append+ +.ih +SEE ALSO +icfit, polyfit +.endhelp diff --git a/pkg/utilities/doc/detab.hlp b/pkg/utilities/doc/detab.hlp new file mode 100644 index 00000000..a84ccf5f --- /dev/null +++ b/pkg/utilities/doc/detab.hlp @@ -0,0 +1,28 @@ +.help detab Mar84 utilities +.ih +NAME +detab -- remove tab characters from a file or files +.ih +USAGE +detab files +.ih +PARAMETERS +.ls files +Template specifying files to be processed e.g. "file1" or "file*". +.le +.ls tablist = "9 +8" +String containing a list of tabstops separated by blanks or commas. +Alternatively a two element string of the form m +n will set +tabstops every n columns beginning in column m. A null string will +default to "9 +8". +.le +.ih +EXAMPLE +Remove the tabs from file "cubspl.f", using the default tab stops. + +.nf + cl> detab cubspl.f > temp + cl> delete cubspl.f + cl> rename temp cubspl.f +.fi +.endhelp diff --git a/pkg/utilities/doc/entab.hlp b/pkg/utilities/doc/entab.hlp new file mode 100644 index 00000000..224f9a82 --- /dev/null +++ b/pkg/utilities/doc/entab.hlp @@ -0,0 +1,30 @@ +.help entab Mar84 utilities +.ih +NAME +entab -- replaces blanks by tabs and blanks +.ih +USAGE +entab files +.ih +PARAMETERS +.ls files +Template specifying the files to be processed, e.g. "file" or "file*". +.le +.ls tablist = "9 +8" +String containing a list of tabstops separated by blanks or commas. +A two element string of the form "m +n" will set +tabstops in every n columns beginning in column m. +A null string defaults to "9 +8". +.le +.ih +EXAMPLE +Convert the file "prog.c", written using full tabstop indents, to +an equivalent file with an initial indent of one full tabstop, +with 4 space indents thereafter. + +.nf + cl> detab prog.c tab='9 +4' | entab > temp + cl> delete prog.c + cl> rename temp prog.c +.fi +.endhelp diff --git a/pkg/utilities/doc/lcase.hlp b/pkg/utilities/doc/lcase.hlp new file mode 100644 index 00000000..4fa859c8 --- /dev/null +++ b/pkg/utilities/doc/lcase.hlp @@ -0,0 +1,32 @@ +.help lcase Jan85 utilities +.ih +NAME +lcase -- convert text files to lower case +.ih +USAGE +lcase files +.ih +PARAMETERS +.ls files +The list of text files to be converted to lower case. If more than one +text file is specified as input the suffix .lc is appended to the input +file name to create the output file name. +.le +.ih +DESCRIPTION +LCASE takes input from a list of text files or the standard input, converts +the text to lower case and prints the result on the standard output. +If multiple files are specified as input, the suffix .lc is appended to +the input file name to create the output file name. +.ih +EXAMPLES +1. Convert a list of files to lower case + +.nf + cl> lcase *.x +.fi + +.ih +SEE ALSO +ucase +.endhelp diff --git a/pkg/utilities/doc/polyfit.hlp b/pkg/utilities/doc/polyfit.hlp new file mode 100644 index 00000000..c9c01a8f --- /dev/null +++ b/pkg/utilities/doc/polyfit.hlp @@ -0,0 +1,91 @@ +.help polyfit Nov87 utilities +.ih +NAME +polyfit -- fit a polynomial to sets of data +.ih +USAGE +polyfit filelist order +.ih +PARAMETERS +.ls \fBfilelist\fR +File containing X,Y, SIGMAY triples to be fit. May be STDIN, or a list +of file names. Note that the third list quantity is only required if +\fIweighting\fR = instrumental. +.le +.ls \fBorder\fR +The order of the polynomial fit. (e.g. a parabolic fit has order 2) +.le +.ls weighting = uniform +The type of weighting for the fit. The choices are: +.ls uniform +No weighting. +.le +.ls instrumental +The weight of each point is equal to 1. / SIGMAY ** 2. +.le +.ls statistical +The weight of each point is equal to 1. / Y. +.le +.le +.ls \fBverbose\fR = no +If \fBverbose\fR = yes, additional information about the fit is printed on +the standard output. +.le +.ls \fBlistdata\fR = no +If \fBlistdata\fR = yes, the only output will be the calculated values for the +X,Y pairs. This is useful as input to \fIgraph\fR. +.le +.ih +DESCRIPTION +A polynomial weighted fit of specified order is fit to the X,Y, SIGMAY data +triples +read from the input file, files, or STDIN. The resulting coefficients +of the polynomial are printed on the first line of the standard output. +The uncertainty in each coefficient is printed on the next line. +These are listed as: + +.br +a0 a1 a2 a3 ... +.br +s0 s1 s2 s3 ... + +.br +where the polynomial has the form: + +.br +y = a0 + a1*x + a2*x**2 + a3*x**3 + ... + +.br +and the coefficients have uncertainties ("sigmas") s0 - sN. + +If verbose is set to yes, the following additional information is +listed: the resulting reduced chi-square, f-test, correlation coefficient, +standard deviation of residuals, and number of items in the list. +Also a tabular listing of each data element, X,Y, SIGMAY and the independent +variable, Yc, as calculated according to the fit, is printed. + +If listdata is set to yes, the only output which will appear will +be the listing of X,Yc,Y, SIGMAY. This provides a list suitable as input to +GRAPH or any other list oriented utility. Setting listdata to yes +overrides the verbose option. + +The routine REGRES from the library of routines written by Bevington is used +for the fit; see \fBData Reduction and Error Analysis\fR, by Bevington. +.ih +EXAMPLES + cl> polyfit STDIN 2 +.br + cl> polyfit datafile 4 verbose+ +.ih +BUGS +The maximum number of data elements is currently limited to 1000 +X,Y,SIGMAY triples. Also the system must be overdetermined. That is, the +number of data elements must exceed the order by at least 2. + +Beware of data elements having large dynamic range. The limitation +of the machine exponent range can produce overflow and underflow +arithmetic exceptions. +.ih +SEE ALSO +curfit +.endhelp diff --git a/pkg/utilities/doc/split.hlp b/pkg/utilities/doc/split.hlp new file mode 100644 index 00000000..e398fe3d --- /dev/null +++ b/pkg/utilities/doc/split.hlp @@ -0,0 +1,59 @@ +.help split Sep86 utilities +.ih +NAME +split -- split a large file into smaller segments +.ih +USAGE +split input output +.ih +PARAMETERS +.ls input +The name of the input file (only a single file can be processed). +.le +.ls output +The root name of the output files. +.le +.ls nlines = 1000 +The maximum number of lines per output segment file, if the input file +is a text file. +.le +.ls nbytes = 16384 +The maximum number of bytes per output segment file, if the input file +is a binary file. +.le +.ls maxfiles = 999 +Maximum number of output files. Used to determine the amount of zero +padding needed for the filename extensions. +.le +.ls verbose = yes +Print the name and size of each output file as it is generated. +.le +.ih +DESCRIPTION +The \fIsplit\fR task is used to break large files up into smaller segments, +e.g., when it is necessary to deal with an unmanageably large file. +Lacking any knowledge of the file structure, the segments are broken on +arbitrarily located but equally spaced boundaries. The segments may +subsequently be reassembled into larger segments of the original file with +\fIconcatenate\fR or \fIcopy\fR (with output redirection), or \fIsplit\fR may +be applied again to break a large segment up into smaller segments without +losing any information. +.ih +EXAMPLES +1. Split a large text file into segments, each of which is the default size. + + cl> split textfile seg + +2. Split a large \fItar\fR format archive file (10240 byte records) up into +a series of smaller files, each of which contains 10 records from the input +tar file. + + cl> split big.arc seg nb=(10240*10) + +.ih +TIME REQUIREMENTS +very fast +.ih +SEE ALSO +concatenate, copy +.endhelp diff --git a/pkg/utilities/doc/surfit.hlp b/pkg/utilities/doc/surfit.hlp new file mode 100644 index 00000000..36b70803 --- /dev/null +++ b/pkg/utilities/doc/surfit.hlp @@ -0,0 +1,257 @@ +.help surfit Jun93 utilities +.ih +NAME +surfit -- fit a surface, z=f(x,y), to a set of x, y, z points +.ih +USAGE +surfit input +.ih +PARAMETERS +.ls input +Input text file containing the data to be fit. The file consists of lines +with three or four whitespace separated values giving x, y, z, and +optionally a weight. +.le +.ls image = "" +Optional image name in which to create an evenly sampled image of the +fitted surface. If no name is specified a image is not created. If an +image name is specified then the x range in the input is evenly divided by +the specified number of image columns, the y range is evenly divided by the +specified number of lines, and the fitted surface values evaluated at the +sampled x and y points are written as the pixel values of the image. A +linear world coordinate system based on the x and y values is also created +for the image. +.le +.ls coordinates = "", fit = "" +The first two columns of the text file specified by the coordinates parameter +are use to supply x and y values which are evaluated by the surface and +the resulting x, y, and z values are appended to the specified fit file. +If either parameter is not specified then this surface evaluation is +not done. Note that the input data points are evaluated as part of +the standard output but one may, if desired, specify the input file +as the coordinate file to create a separate output. +.le + +.ls function = "polynomial" (chebyshev|legendre|polynomial) +Surface function type to fit. The choices are a chebyshev, legendre, +or simple power series bi-dimensional polynomial. +.le +.ls xorder = 2, yorder = 2 +The polynomial orders in x and y. +.le +.ls xterms = "full" +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 (xorder - 1, yorder - 1). +.le +.ls full +The individual polynomial terms contain powers of x and powers of y, whose +maximum combined power is max (xorder - 1 + yorder - 1). +.le +.le +.ls weighting = "user" (uniform|user|statistical|instrumental) +The type of weighting for the fit. The options are: +.ls uniform +All weights are 1. Any input weights are ignored. +.le +.ls user +The weights in the fourth input column are used. If no weight is given +a weight of 1 is supplied. +.le +.ls statistical +The reciprocal of the absolute value of z input data is used as the weight. +Any input weights are ignored. Z values less than 1e-20 are set to 1e-20. +.le +.ls instrumental +The fourth input column is taken as a sigma and the weight is the +reciprocal of the sigma squared. If no sigma is given a sigma of +1 is supplied. Sigma values less than 1e-10 are set to 1e-10. +.le +.le +.ls xmin = INDEF, xmax = INDEF, ymin = INDEF, ymax = INDEF +These parameters define the range of input x and y data to be used and +also define the range over which the surface function is defined. If +INDEF then the appropriate limit from the input data points is used. +If input data points lie outside these limits they are discarded. The +range may be given larger than the range of the input data in order +to all evaluating coordinates outside input data; i.e. to +allow extrapolation. +.le +.ls zmin = INDEF, zmax = INDEF +These parameters apply threshold limits to the input data. If INDEF +the appropriate limit from the input data points is used. Input +data points with z values outside this range are discarded. +.le +.ls ncols = 100, nlines = 100 +The number of columns and lines for the optional surface image. These +parameters determine the size of the image and how finely the x and +y input data range is subdivided. +.le +.ih +DESCRIPTION +This task fits a surface, a function of two coordinates, to a set of +possibly irregularly sampled data points specified in a text file. +The input consists of a file with three or four columns. The first +two columns define the two coordinates, called x and y, the third +column gives the value the function is supposed to fit, called z, +and the optional fourth column is a weight or sigma. If a weight or +sigma is not specified it will have a unit weight or sigma. The type +of weighting is selected by a task parameter. + +The input data points may be restricted by use of the \fIxmin, xmax, +ymin, ymax, zmin, zmax\fR parameters. If these parameters are INDEF +(the default) the full range of the input is used. The surface function +is only defined within the specified x and y range. In order to +extrapolate outside the range of the input data these limits must +be specified explicitly. + +The functions which may be fit are legendre, chebyshev, or simple +power series bi-dimensional polynomials. The user selects the +function type, the order in x and y, and whether to include +cross terms. The orders are the number of coefficients which +is the highest polynomial power plus 1. For example the default +values of 2 in each coordinate define a linear sloped plane. +All computations are done in double precision. + +Several polynomial cross terms options are available. Options "none", +"half", and "full" are illustrated below for a quadratic polynomial in +x and y. + +.nf +xterms = "none" +xorder = 3, yorder = 3 + + z = a11 + a21 * x + a12 * y + a31 * x ** 2 + a13 * y ** 2 + +xterms = "half" +xorder = 3, yorder = 3 + + z = a11 + a21 * x + a12 * y + a31 * x ** 2 + a22 * x * y + a13 * y ** 2 + +xterms = "full" +xorder = 3, yorder = 3 + + z = 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 + + +The fit results are written to the standard output; the terminal unless +redirected. It consists of the input parameters, the coefficients and +errors, and the input data plus the fitted values and residuals. The +coefficient lines contain four columns. The first two columns are the x +and y polynomial powers and then the coefficient and error in the +coefficient are given. The coefficients are determined based on a +normalized coordinate; the range of input x and y values, which is shown in +the output as xmin, xmax, ymin, and ymax, is mapped to the range -1 to 1. +The data portion gives the x, y, and z input values followed by the fitted +value and the residual (z - fit) and finally the weight. + +There are two types of additional output which may be selected if desired. +One is a two dimensional image of the surface evenly sampled over the x and +y data range set by the xmin, xmax, ymin, ymax parameters. This type of +output is selected by specifying an image name and the number of columns +and lines. The number of columns and lines defines the size of the image +and also the sampling of the x and y values. The first pixel in each +dimension is the minimum x or y value and the sample interval per pixel is +given by: + +.nf + dx = (xmax - xmin) / (ncols - 1) + dy = (ymax - ymin) / (nlines - 1) +.fi + +The fitted surface is evaluated at each pixel and written to the image. +The linear world coordinate system defining the x and y pixel sampling is +written to the image header. This allows tasks such as \fBimplot\fR and +\fBlistpixels\fR to show the fitted values in the input x and y units. + +The second type of output allows the surface to be evaluated at an +arbitrary set of x and y coordinates. The coordinates are input +as a text file. The first two columns are taken as the x and y values +and any other columns are ignored. The x and y values and the fitted +values are appended to a specified text file. This output is +optional and only occurs if both an input coordinate and output +fit file are specified. Note that the input data points are +always evaluated as part of the standard output but the input +data file may also be used as a coordinate file if desired. +Also the output data file may be specified as "STDOUT" to merge +this output with the basic results output. +.ih +EXAMPLES +1. The following example shows use of all the output options using some +random numbers. + +.nf + cl> urand 50 3 scale=100. >sf1 + cl> head sf1 nl=5 + 70.87 42.5 99.06 + 51.49 42.19 64.86 + 70.75 83.34 80.39 + 57.1 67.79 30.24 + 60.91 49.76 53.32 + + cl> urand 5 2 scale=100. seed=2 >sf2 + cl> head sf2 + 20.62 17.86 + 66.39 86.26 + 48.08 35.07 + 70.39 95.8 + 53.64 15.51 + + cl> surfit sf1 image=sf coord=sf2 fit=sf3 ncols=20 nlines=20 + Surface parameters: + function = polynomial + xorder = 2 + yorder = 2 + xterms = full + weighting = user + xmin = 0.684 + xmax = 89.74 + ymin = 1.051 + ymax = 95.36 + zmin = 1.217 + zmax = 99.14 + + + Surface coefficients: + x y coeff error + 0 0 75.7125 17.2504 + 1 0 -0.37273 0.356014 + 0 1 -0.77194 0.336627 + 1 1 0.009884 0.006295 + + Fitted points: + x y z fit residual weight + 70.87 42.5 99.06 46.2611 52.7989 1. + 51.49 42.19 64.86 45.4249 19.4351 1. + 70.75 83.34 80.39 43.2899 37.1001 1. + 57.1 67.79 30.24 40.3604 -10.1204 1. + 60.91 49.76 53.32 44.5562 8.76384 1. + ... + + chisqr = 903.797 + + cl> head sf3 + 20.62 17.86 57.8802 + 66.39 86.26 40.9855 + 48.08 35.07 47.3864 + 53.64 15.51 51.9697 + + cl> listpix sf[*:10,*:10] wcs=world formats="%5.2f %5.2f" + 0.68 1.05 74.65366 + 47.56 1.05 57.66973 + 0.68 50.69 36.67273 + 47.56 50.69 42.6855 +.fi +.ih +SEE ALSO +apphot.fitsky, apphot.txdump, imsurfit +.endhelp diff --git a/pkg/utilities/doc/translit.hlp b/pkg/utilities/doc/translit.hlp new file mode 100644 index 00000000..aba81f86 --- /dev/null +++ b/pkg/utilities/doc/translit.hlp @@ -0,0 +1,49 @@ +.help translit Mar84 utilities +.ih +NAME +translit -- replace or delete specified characters in a file +.ih +USAGE +translit infile from_string [to_string] +.ih +PARAMETERS +.ls infile +The input file name or template, e.g. "abc" or "abc.*". +.le +.ls from_string +String containing characters to be mapped. +If delete is yes then the characters in from_string are deleted from the input +file(s). The from_string may specify a range of characters, e.g. "a-z" or "A-Z". +If the first character of from_string is ^ then the program will operate +on all but the specified characters, e.g. "^a-z" means all but lower case +alphabetic characters. +.le +.ls to_string +Requested if delete is no, otherwise set to the null string. +Characters in from_string are mapped into characters in to_string. +When to_string is short with respect to from_string, it is padded +by duplicating the last character. +.le +.ls delete = no +If delete is yes the characters in from_string are deleted from the input +file(s) and no to_string is requested. +.le +.ls collapse = no +If this switch is set all strings of repeatedly mapped output characters +are squeezed to a single character. +.le +.ih +EXAMPLES +To change all the alphabetic characters in a file from lower to upper +case, writing the result on the standard output: + + cl> translit filename a-z A-Z + +To delete the letters a, b, and c from a file: + + cl> translit filename abc de=yes + +To replace all but the letters abc in a file with A: + + cl> translit filename ^abc A +.endhelp diff --git a/pkg/utilities/doc/ucase.hlp b/pkg/utilities/doc/ucase.hlp new file mode 100644 index 00000000..e776ac16 --- /dev/null +++ b/pkg/utilities/doc/ucase.hlp @@ -0,0 +1,32 @@ +.help ucase Jan85 utilities +.ih +NAME +ucase -- convert text files to upper case +.ih +USAGE +ucase files +.ih +PARAMETERS +.ls files +The list of text files to be converted to upper case. If more than one +text file is specified as input the suffix .uc is appended to the input +file name to create the output file name. +.le +.ih +DESCRIPTION +UCASE takes input from a list of text files or the standard input, converts +the text to upper case and prints the result on the standard output. +If multiple files are specified as input, the suffix .uc is appended to +the input file name to create the output file name. +.ih +EXAMPLES +1. Convert a list of files to upper case + +.nf + cl> ucase *.x +.fi + +.ih +SEE ALSO +lcase +.endhelp diff --git a/pkg/utilities/doc/urand.hlp b/pkg/utilities/doc/urand.hlp new file mode 100644 index 00000000..f5e54263 --- /dev/null +++ b/pkg/utilities/doc/urand.hlp @@ -0,0 +1,41 @@ +.help urand Mar84 utilities +.ih +NAME +urand -- uniform random number generator +.ih +USAGE +urand nlines ncols +.ih +PARAMETERS +.ls nlines +The number of lines of output to be generated. +.le +.ls ncols +The number of random numbers per output line. +.le +.ls ndigits = 4 +Number of digits of precision in each random number. +.le +.ls scale_factor = 1.0 +Factor by which the numbers are to be scaled (multiplied). +.le +.ls seed = 1 +Seed for the random number generator. If the value is "INDEF" then +the clock time (integer seconds since 1980) is used as the seed +value giving different random numbers for different executions. +.le +.ih +DESCRIPTION +The system random number generator is called to generate a sequence of +random numbers in list form. By default, the random numbers will +be uniformly distributed over the range 0 to 1. The number of lines +of output, number of columns (random numbers) per line, and number of +significant digits in each number may all be set by the caller. +.ih +EXAMPLES +Generate a sequence of 100 random numbers and graph them on the graphics +terminal in point plot mode. Autoscaling is turned off so that the plot +will be scaled to the rand 0-1 (the \fBgraph\fR defaults) in both axes. + + cl> urand 100 2 | graph po+ xa- ya- +.endhelp diff --git a/pkg/utilities/entab.par b/pkg/utilities/entab.par new file mode 100644 index 00000000..c992ed14 --- /dev/null +++ b/pkg/utilities/entab.par @@ -0,0 +1,2 @@ +files,s,a,,,,list of files to be entabbed +tablist,s,h,"9 +8",,,list of tab stops diff --git a/pkg/utilities/lcase.par b/pkg/utilities/lcase.par new file mode 100644 index 00000000..1c0e4e51 --- /dev/null +++ b/pkg/utilities/lcase.par @@ -0,0 +1 @@ +files,s,a,,,,list of files to be converted to lower case diff --git a/pkg/utilities/mkpkg b/pkg/utilities/mkpkg new file mode 100644 index 00000000..9d0a7517 --- /dev/null +++ b/pkg/utilities/mkpkg @@ -0,0 +1,51 @@ +# Make the UTILITIES package + +$call relink +$exit + +update: + @nttools + + $call relink + $call install + ; + +relink: + @nttools + + $set LIBS = "-lxtools -lcurfit -lbev -lgsurfit" + + $update libpkg.a + $omake x_utilities.x + $link x_utilities.o libpkg.a $(LIBS) -o xx_utilities.e + ; + +install: + $move xx_utilities.e bin$x_utilities.e + ; + +generic: + $set GEN = "$$generic -k" + $ifolder (curfit.x, curfit.gx) $(GEN) curfit.gx -o curfit.x $endif + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + curfit.x curfit.h \ + + decod_tablst.x + t_lcase.x + pfregres.f + pffctn.x + t_split.x + t_curfit.x \ + + t_detab.x + t_entab.x + t_polyfit.x + t_surfit.x + t_translit.x + t_ucase.x + t_urand.x + ; diff --git a/pkg/utilities/nttools/README b/pkg/utilities/nttools/README new file mode 100644 index 00000000..804a2a35 --- /dev/null +++ b/pkg/utilities/nttools/README @@ -0,0 +1,32 @@ +These directories contain tasks for working with tables. The various +subdirectories and the tasks that they contain are as follows: + +copyone keypar, keytab, parkey, partab, tabkey, tabpar +doc help files +gtedit gtedit +keyselect keyselect +lib subroutines used by more than one task +tcalc tcalc +tchcol tchcol +tchsize tchsize +tcopy tcopy, tdelete +tcreate tcreate +tdiffer tdiffer +tedit tedit, tread +texpand texpand +thedit thedit, thselect +tinfo tinfo, tlcol +tintegrate tintegrate +tjoin tjoin +tlinear tlinear +tmerge tmerge +tprint tdump, tprint +tproduct tproduct +tproject tproject +tquery tquery +trebin trebin +tselect tselect +tsort tsort +tstat thistogram, tstat +tunits tunits +tupar tupar diff --git a/pkg/utilities/nttools/atools/mkpkg b/pkg/utilities/nttools/atools/mkpkg new file mode 100644 index 00000000..7c969a01 --- /dev/null +++ b/pkg/utilities/nttools/atools/mkpkg @@ -0,0 +1,10 @@ +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + taextract.x + tainsert.x + taincr.x + ; diff --git a/pkg/utilities/nttools/atools/taextract.x b/pkg/utilities/nttools/atools/taextract.x new file mode 100644 index 00000000..a89be676 --- /dev/null +++ b/pkg/utilities/nttools/atools/taextract.x @@ -0,0 +1,214 @@ +include + +define BUFSIZE 1024 # max number of elements copied at one time + +# taextract -- copy an entry from one table to another +# This task extracts an entry at a specified row & column (presumably +# an array of values) and writes it as a column of scalar values to +# another table. If the output table exists it will be written to in-place; +# otherwise, it will be created. The same column name is used in both +# tables. The input row number is written to the header of the output +# table using keyword ORIG_ROW. +# +# Phil Hodge, 28-Jul-1994 Task created. +# Phil Hodge, 15-Dec-1995 Add nremain, fix while loop on ncopy. +# Phil Hodge, 29-Jul-1997 Rename delete to delete_flag to avoid confusion +# with the delete subroutine. +# Phil Hodge, 30-Jan-1998 Add optional parameters to define new column. +# Phil Hodge, 8-Apr-1999 Call tbfpri. + +procedure taextract() + +pointer intable +pointer outtable +int row # row number at which to extract +char column[SZ_COLNAME] # name of column from which to extract +char outcolumn[SZ_COLNAME] # name to use for column in output table +char colunits[SZ_COLUNITS] # units for new column +char colfmt[SZ_COLFMT] # display format for new column +pointer dtype # data type of new column +#-- +pointer sp +pointer x # scratch for array of data +pointer itp, otp # pointers to table structs +pointer icp, ocp # pointers to column structs +int datatype # data type of column +char icolname[SZ_COLNAME] # from tbcinf for input table column +char icolunits[SZ_COLUNITS] # from tbcinf, units for column +char icolfmt[SZ_COLFMT] # from tbcinf, display format +int idatatype # from tbcinf, data type of column +int colnum, lenfmt # output from tbcinf and ignored +int nelem # input length of array, output number of rows +int nremain # number of elements that remain to be copied +int ncopy # number of elements to copy at once +int i # loop index +int first, last # first and last elements (or rows) +int slen # length of string to copy +int phu_copied # set by tbfpri and ignored +bool inplace # true if output table already exists +bool newcolumn # true if output column does not already exist +int delete_flag # should we delete output table if error? +pointer tbtopn() +int clgeti(), tbpsta(), tbtacc(), tbcigi() +int tbagtr(), tbagtd(), tbagti(), tbagts(), tbagtb(), tbagtt() +bool isblank() + +begin + call smark (sp) + call salloc (intable, SZ_FNAME, TY_CHAR) + call salloc (outtable, SZ_FNAME, TY_CHAR) + call salloc (dtype, SZ_FNAME, TY_CHAR) + + call clgstr ("intable", Memc[intable], SZ_FNAME) + call clgstr ("outtable", Memc[outtable], SZ_FNAME) + row = clgeti ("row") + call clgstr ("column", column, SZ_COLNAME) + call clgstr ("outcolumn", outcolumn, SZ_COLNAME) + + # The input column name is the default for the output. + if (isblank (outcolumn)) + call strcpy (column, outcolumn, SZ_COLNAME) + + # Open input and output tables. + itp = tbtopn (Memc[intable], READ_ONLY, NULL) + if (tbtacc (Memc[outtable]) == YES) { + otp = tbtopn (Memc[outtable], READ_WRITE, NULL) + inplace = true + } else { + call tbfpri (Memc[intable], Memc[outtable], phu_copied) + otp = tbtopn (Memc[outtable], NEW_FILE, NULL) + inplace = false + } + if (inplace) + delete_flag = NO + else + delete_flag = YES # delete output table in case of error + + if (row < 1 || row > tbpsta (itp, TBL_NROWS)) { + call taex_disaster (itp, otp, NO, "row not found in input table") + } + + # Find input column. + call tbcfnd (itp, column, icp, 1) + if (icp == NULL) + call taex_disaster (itp, otp, NO, "column not found in input table") + + # Find or create output column. + call tbcfnd (otp, outcolumn, ocp, 1) + if (ocp == NULL) { + # Column not found in output. Create it using the input column + # as a template, except that the output will not be an array. + # The name might also be different. + call tbcinf (icp, colnum, icolname, icolunits, icolfmt, + idatatype, nelem, lenfmt) + # Get optional parameters if creating new column. + call clgstr ("colunits", colunits, SZ_COLUNITS) + call clgstr ("colfmt", colfmt, SZ_COLFMT) + call clgstr ("datatype", Memc[dtype], SZ_FNAME) + # Assign default values if not specified. + if (isblank (colunits)) + call strcpy (icolunits, colunits, SZ_COLUNITS) + if (isblank (colfmt)) + call strcpy (icolfmt, colfmt, SZ_COLFMT) + if (isblank (Memc[dtype])) + datatype = idatatype + else + call tbbtyp (Memc[dtype], datatype) + call tbcdef (otp, ocp, outcolumn, colunits, colfmt, + datatype, 1, 1) # a column of scalars + newcolumn = true + } else { + newcolumn = false + } + if (!inplace) + call tbtcre (otp) + + # Save the row number as a header parameter. + call tbhadi (otp, "orig_row", row) + + # Get number of elements to copy. + nelem = tbcigi (icp, TBL_COL_LENDATA) + nremain = nelem # initialize to total number to copy + ncopy = min (nremain, BUFSIZE) + first = 1 + last = ncopy + + # Copy the data. + datatype = tbcigi (icp, TBL_COL_DATATYPE) + if (datatype == TY_REAL) { + call salloc (x, ncopy, TY_REAL) + while (ncopy > 0) { + if (tbagtr (itp, icp, row, Memr[x], first, ncopy) < ncopy) + call taex_disaster (itp, otp, delete_flag, + "error reading input") + call tbcptr (otp, ocp, Memr[x], first, last) + call taex_incr (nremain, ncopy, first, last, BUFSIZE) + } + + } else if (datatype == TY_DOUBLE) { + call salloc (x, ncopy, TY_DOUBLE) + while (ncopy > 0) { + if (tbagtd (itp, icp, row, Memd[x], first, ncopy) < ncopy) + call taex_disaster (itp, otp, delete_flag, + "error reading input") + call tbcptd (otp, ocp, Memd[x], first, last) + call taex_incr (nremain, ncopy, first, last, BUFSIZE) + } + + } else if (datatype == TY_INT) { + call salloc (x, ncopy, TY_INT) + while (ncopy > 0) { + if (tbagti (itp, icp, row, Memi[x], first, ncopy) < ncopy) + call taex_disaster (itp, otp, delete_flag, + "error reading input") + call tbcpti (otp, ocp, Memi[x], first, last) + call taex_incr (nremain, ncopy, first, last, BUFSIZE) + } + + } else if (datatype == TY_SHORT) { + call salloc (x, ncopy, TY_SHORT) + while (ncopy > 0) { + if (tbagts (itp, icp, row, Mems[x], first, ncopy) < ncopy) + call taex_disaster (itp, otp, delete_flag, + "error reading input") + call tbcpts (otp, ocp, Mems[x], first, last) + call taex_incr (nremain, ncopy, first, last, BUFSIZE) + } + + } else if (datatype == TY_BOOL) { + call salloc (x, ncopy, TY_BOOL) + while (ncopy > 0) { + if (tbagtb (itp, icp, row, Memb[x], first, ncopy) < ncopy) + call taex_disaster (itp, otp, delete_flag, + "error reading input") + call tbcptb (otp, ocp, Memb[x], first, last) + call taex_incr (nremain, ncopy, first, last, BUFSIZE) + } + + } else if (datatype < 0) { # character string + slen = -datatype + 3 # a little extra space + call salloc (x, slen, TY_CHAR) + do i = 1, nelem { + if (tbagtt (itp, icp, row, Memc[x], slen, i, 1) < 1) + call taex_disaster (itp, otp, delete_flag, + "error reading input") + call tbeptt (otp, ocp, i, Memc[x]) + } + + } else { + call taex_disaster (itp, otp, delete_flag, "unknown data type") + } + + # If we wrote to an existing column in an existing table, and the + # output table has more rows than we just wrote, then we should set + # the remaining rows in this column to INDEF. + if (!newcolumn) { + do i = nelem+1, tbpsta (otp, TBL_NROWS) + call tbrudf (otp, ocp, 1, i) + } + + call tbtclo (otp) + call tbtclo (itp) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/atools/taincr.x b/pkg/utilities/nttools/atools/taincr.x new file mode 100644 index 00000000..7d297e23 --- /dev/null +++ b/pkg/utilities/nttools/atools/taincr.x @@ -0,0 +1,55 @@ +# This file contains taex_incr and taex_disaster, which are used by +# both tainsert and taextract. +# +# Phil Hodge, 7-Mar-1996 Extracted from taextract.x. +# Phil Hodge, 29-Jul-1997 In taex_disaster, get table name before closing +# the table; rename delete to delete_flag to avoid +# confusion with the delete subroutine. + +# taex_incr -- increment variables + +# On input, ncopy is the number of elements that were copied in +# the previous step. We decrement nremain and increment first by +# this amount. Then we determine the appropriate value of ncopy +# for the next step and update last. + +procedure taex_incr (nremain, ncopy, first, last, bufsize) + +int nremain # io: number of elements remaining to be copied +int ncopy # io: number of elements copied/to copy next +int first # io: first element (or row number) +int last # io: last element (or row number) +int bufsize # i: maximum number to copy in one step + +begin + nremain = nremain - ncopy + first = first + ncopy + ncopy = min (nremain, bufsize) + last = first + ncopy - 1 +end + +# taex_disaster -- clean up and call error + +procedure taex_disaster (itp, otp, delete_flag, message) + +pointer itp, otp # io: pointers to table struct +int delete_flag # i: YES if we should delete the output table +char message[ARB] # i: error message +#-- +pointer sp +pointer outtable # scratch for name of output table + +begin + call tbtclo (itp) + if (delete_flag == YES) { + call smark (sp) + call salloc (outtable, SZ_FNAME, TY_CHAR) + call tbtnam (otp, Memc[outtable], SZ_FNAME) + call tbtclo (otp) + call tbtdel (Memc[outtable]) + call sfree (sp) + } else { + call tbtclo (otp) + } + call error (1, message) +end diff --git a/pkg/utilities/nttools/atools/tainsert.x b/pkg/utilities/nttools/atools/tainsert.x new file mode 100644 index 00000000..125ed348 --- /dev/null +++ b/pkg/utilities/nttools/atools/tainsert.x @@ -0,0 +1,260 @@ +include + +define BUFSIZE 1024 # max number of elements copied at one time + +# tainsert -- copy a column from one table to an entry in another +# This task inserts an array of values into a row for a column that contains +# array entries. If the output table exists it will be written to in-place; +# otherwise, it will be created. The same column name is used in both +# tables. If the row number is less than one, the output row number will be +# taken from the keyword ORIG_ROW in the input table. +# +# Phil Hodge, 28-Jul-1994 Task created. +# Phil Hodge, 15-Dec-1995 Add nremain, fix while loop on ncopy. +# Phil Hodge, 4-Apr-1996 Remove slen from calling sequence of tbaptr, etc., +# for writing indef to extra elements of array. +# Phil Hodge, 30-Jan-1998 Add optional parameters to define new column; +# call tbhgti as a function, not a subroutine. +# Phil Hodge, 8-Apr-1999 Call tbfpri. +# Phil Hodge, 13-Apr-2000 Add column name to warning message. + +procedure tainsert() + +pointer intable +pointer outtable +int row # row number at which to insert +char column[SZ_COLNAME] # name of column to copy +char outcolumn[SZ_COLNAME] # name to use for column in output table +int size # length of output array for new column +char colunits[SZ_COLUNITS] # units for new column +char colfmt[SZ_COLFMT] # display format for new column +pointer dtype # data type of new column +#-- +pointer sp +pointer x # scratch for array of data +pointer nbuf # scratch for array of null flags +pointer itp, otp # pointers to table structs +pointer icp, ocp # pointers to column structs +int datatype # data type of column +char icolname[SZ_COLNAME] # from tbcinf for input table column +char icolunits[SZ_COLUNITS] # from tbcinf, units for column +char icolfmt[SZ_COLFMT] # from tbcinf, display format +int idatatype # from tbcinf, data type of column +int colnum, lenfmt # output from tbcinf and ignored +int nrows # number of rows in input table +int nelem # input number of rows, output length of array +int nremain # number of elements that remain to be copied +int ncopy # number of elements to copy at once +int i # loop index +int first, last # first and last elements (or rows) +int slen # length of string to copy +int phu_copied # set by tbfpri and ignored +bool inplace # true if output table already exists +bool newcolumn # true if output column does not already exist +int delete # should we delete output table if error? +pointer tbtopn() +int clgeti(), tbpsta(), tbtacc(), tbcigi(), tbhgti() +bool isblank() + +# INDEF values for use in a calling sequence: +# (The problem is that INDEFS is an int, not a short; the others may be OK.) +double undefd +real undefr +int undefi +short undefs + +begin + call smark (sp) + call salloc (intable, SZ_FNAME, TY_CHAR) + call salloc (outtable, SZ_FNAME, TY_CHAR) + call salloc (dtype, SZ_FNAME, TY_CHAR) + + call clgstr ("intable", Memc[intable], SZ_FNAME) + call clgstr ("outtable", Memc[outtable], SZ_FNAME) + row = clgeti ("row") + call clgstr ("column", column, SZ_COLNAME) + call clgstr ("outcolumn", outcolumn, SZ_COLNAME) + + # The input column name is the default for the output. + if (isblank (outcolumn)) + call strcpy (column, outcolumn, SZ_COLNAME) + + # Open input and output tables. + itp = tbtopn (Memc[intable], READ_ONLY, NULL) + if (tbtacc (Memc[outtable]) == YES) { + otp = tbtopn (Memc[outtable], READ_WRITE, NULL) + inplace = true + } else { + call tbfpri (Memc[intable], Memc[outtable], phu_copied) + otp = tbtopn (Memc[outtable], NEW_FILE, NULL) + inplace = false + } + if (inplace) + delete = NO + else + delete = YES # delete output table in case of error + + undefd = INDEFD + undefr = INDEFR + undefi = INDEFI + undefs = INDEFS + + if (row < 1 || IS_INDEFI(row)) { + iferr (row = tbhgti (itp, "orig_row")) + call taex_disaster (itp, otp, NO, + "row number not specified, and ORIG_ROW not found in intable") + } + + # This will be the number of elements in the output array, + # unless the user explicitly specifies a different size. + nrows = tbpsta (itp, TBL_NROWS) + + # Find input column. + call tbcfnd (itp, column, icp, 1) + if (icp == NULL) + call taex_disaster (itp, otp, NO, "column not found in input table") + + # Find or create output column. If we're creating a new column, + # use the input column as a template, except that the output will be + # an array of length 'size', which defaults to nrows but can be + # different if the user specifies a value. The name of the output + # column can also be different from the input. + call tbcfnd (otp, outcolumn, ocp, 1) + if (ocp == NULL) { + # Column not found in output, so create it. + call tbcinf (icp, colnum, icolname, icolunits, icolfmt, + idatatype, nelem, lenfmt) + if (nelem > 1) + call taex_disaster (itp, otp, NO, + "column in input table contains arrays") + # Get optional parameters if creating new column. + size = clgeti ("size") + call clgstr ("colunits", colunits, SZ_COLUNITS) + call clgstr ("colfmt", colfmt, SZ_COLFMT) + call clgstr ("datatype", Memc[dtype], SZ_FNAME) + # Assign default values if not specified. + if (IS_INDEFI(size) || size < 1) + size = nrows + if (isblank (colunits)) + call strcpy (icolunits, colunits, SZ_COLUNITS) + if (isblank (colfmt)) + call strcpy (icolfmt, colfmt, SZ_COLFMT) + if (isblank (Memc[dtype])) { + datatype = idatatype + } else { + # convert e.g. "real" to 6 + call tbbtyp (Memc[dtype], datatype) + } + call tbcdef (otp, ocp, outcolumn, colunits, colfmt, + datatype, size, 1) # an array + newcolumn = true + } else { + newcolumn = false + } + if (!inplace) + call tbtcre (otp) + + # Get number of elements to copy. + nelem = tbcigi (ocp, TBL_COL_LENDATA) + if (nrows > nelem) { + call eprintf ( +"Warning: The number of input rows (%d) in column %s\n") + call pargi (nrows) + call pargstr (column) + call eprintf ( +" is greater than the array size (%d); the extra rows will be ignored.\n") + call pargi (nelem) + } + nremain = min (nrows, nelem) # total number to copy + ncopy = min (nremain, BUFSIZE) + first = 1 + last = ncopy + + # Copy the data. + datatype = tbcigi (icp, TBL_COL_DATATYPE) + call salloc (nbuf, ncopy, TY_BOOL) + if (datatype == TY_REAL) { + call salloc (x, ncopy, TY_REAL) + while (ncopy > 0) { + call tbcgtr (itp, icp, Memr[x], Memb[nbuf], first, last) + call tbaptr (otp, ocp, row, Memr[x], first, ncopy) + call taex_incr (nremain, ncopy, first, last, BUFSIZE) + } + + } else if (datatype == TY_DOUBLE) { + call salloc (x, ncopy, TY_DOUBLE) + while (ncopy > 0) { + call tbcgtd (itp, icp, Memd[x], Memb[nbuf], first, last) + call tbaptd (otp, ocp, row, Memd[x], first, ncopy) + call taex_incr (nremain, ncopy, first, last, BUFSIZE) + } + + } else if (datatype == TY_INT) { + call salloc (x, ncopy, TY_INT) + while (ncopy > 0) { + call tbcgti (itp, icp, Memi[x], Memb[nbuf], first, last) + call tbapti (otp, ocp, row, Memi[x], first, ncopy) + call taex_incr (nremain, ncopy, first, last, BUFSIZE) + } + + } else if (datatype == TY_SHORT) { + call salloc (x, ncopy, TY_SHORT) + while (ncopy > 0) { + call tbcgts (itp, icp, Mems[x], Memb[nbuf], first, last) + call tbapts (otp, ocp, row, Mems[x], first, ncopy) + call taex_incr (nremain, ncopy, first, last, BUFSIZE) + } + + } else if (datatype == TY_BOOL) { + call salloc (x, ncopy, TY_BOOL) + while (ncopy > 0) { + call tbcgtb (itp, icp, Memb[x], Memb[nbuf], first, last) + call tbaptb (otp, ocp, row, Memb[x], first, ncopy) + call taex_incr (nremain, ncopy, first, last, BUFSIZE) + } + + } else if (datatype < 0) { # character string + slen = -datatype + 3 # a little extra space + call salloc (x, slen, TY_CHAR) + do i = 1, nelem { + call tbegtt (itp, icp, i, Memc[x], slen) + call tbaptt (otp, ocp, row, Memc[x], slen, i, 1) + } + + } else { + call eprintf ("datatype = %d\n") + call pargi (datatype) + call taex_disaster (itp, otp, delete, "unknown data type") + } + + # If we wrote to an existing column in an existing table, and the + # output column array has more elements than input rows, then we + # should set the remaining elements in this entry to INDEF. + if (!newcolumn) { + if (datatype == TY_REAL) { + do i = nrows+1, nelem + call tbaptr (otp, ocp, row, undefr, i, 1) + } else if (datatype == TY_DOUBLE) { + do i = nrows+1, nelem + call tbaptd (otp, ocp, row, undefd, i, 1) + } else if (datatype == TY_INT) { + do i = nrows+1, nelem + call tbapti (otp, ocp, row, undefi, i, 1) + } else if (datatype == TY_SHORT) { + do i = nrows+1, nelem + call tbapts (otp, ocp, row, undefs, i, 1) + } else if (datatype == TY_BOOL) { + do i = nrows+1, nelem + call tbaptb (otp, ocp, row, false, i, 1) + } else if (datatype < 0) { + slen = -datatype + do i = nrows+1, nelem + call tbaptt (otp, ocp, row, "", slen, i, 1) + } + } + + call tbtclo (otp) + call tbtclo (itp) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/copyone/addslash.x b/pkg/utilities/nttools/copyone/addslash.x new file mode 100644 index 00000000..6c5c2ded --- /dev/null +++ b/pkg/utilities/nttools/copyone/addslash.x @@ -0,0 +1,32 @@ +# ADDSLASH -- Convert a string by prefixing quote marks with backslashes +# +# B.Simon 30-Sep-87 First Code + +procedure addslash (str, maxch) + +char str[ARB] # String to be converted +int maxch # Maximum length of string + +int i, j +pointer sp, aux + +begin + call smark (sp) + call salloc (aux, maxch, TY_CHAR) + + j = 1 + for (i = 1; (str[i] != EOS) && (j <= maxch); i = i + 1) { + if (str[i] == '"') { + if (j == maxch) + break + Memc[aux+j-1] = '\\' + j = j + 1 + } + Memc[aux+j-1] = str[i] + j = j + 1 + } + + Memc[aux+j-1] = EOS + call strcpy (Memc[aux], str, maxch) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/copyone/datatype.x b/pkg/utilities/nttools/copyone/datatype.x new file mode 100644 index 00000000..d35732f9 --- /dev/null +++ b/pkg/utilities/nttools/copyone/datatype.x @@ -0,0 +1,79 @@ +include + +# DATATYPE -- Determine the data type of a character string token +# +# B.Simon 13-Aug-87 First Code +# B.Simon 27-Jul-94 Distinguish between double and real +# B.Simon 15-Sep-94 Add check of token length for TY_CHAR +# B.Simon 15-Dec-94 Replace test for double + +int procedure datatype (token) + +char token[ARB] # i: Character string token +#-- +int ic, dtype, nchar, ndigit +pointer sp, utoken + + +bool streq() +int nowhite(), lexnum(), is_double() + +begin + # Convert token to upper case with no whitespace + + call smark (sp) + call salloc (utoken, SZ_LINE, TY_CHAR) + + nchar = nowhite (token, Memc[utoken], SZ_LINE) + call strupr (Memc[utoken]) + + # Determine if token is a number + + ic = 1 + switch (lexnum (Memc[utoken], ic, ndigit)) { + case LEX_OCTAL : + dtype = TY_INT + case LEX_DECIMAL : + dtype = TY_INT + case LEX_HEX : + dtype = TY_CHAR + case LEX_REAL : + dtype = TY_REAL + case LEX_NONNUM : + dtype = TY_CHAR + } + + # Check number of digits parsed against length of string + # if it is shorter, we have a character string that starts + # with a digit + + if (ndigit != nchar) + dtype = TY_CHAR + + # Determine if string is boolean + + switch (Memc[utoken]) { + case 'T': + if (streq (Memc[utoken],"T") || streq (Memc[utoken],"TRUE")) + dtype = TY_BOOL + case 'F': + if (streq (Memc[utoken],"F") || streq (Memc[utoken],"FALSE")) + dtype = TY_BOOL + case 'Y': + if (streq (Memc[utoken],"Y") || streq (Memc[utoken],"YES")) + dtype = TY_BOOL + case 'N': + if (streq (Memc[utoken],"N") || streq (Memc[utoken],"NO")) + dtype = TY_BOOL + } + + # Determine if datatype is real or double by the number of digits + # and / or the presence of "D" + + if (dtype == TY_REAL) + dtype = is_double (Memc[utoken]) + + call sfree (sp) + return (dtype) +end + diff --git a/pkg/utilities/nttools/copyone/filetype.h b/pkg/utilities/nttools/copyone/filetype.h new file mode 100644 index 00000000..b2d84cc6 --- /dev/null +++ b/pkg/utilities/nttools/copyone/filetype.h @@ -0,0 +1,5 @@ +# Symbolic representation of file types supported by SDAS + +define UNKNOWN_FILE 0 +define IMAGE_FILE 1 +define TABLE_FILE 2 diff --git a/pkg/utilities/nttools/copyone/filetype.x b/pkg/utilities/nttools/copyone/filetype.x new file mode 100644 index 00000000..3424b5ea --- /dev/null +++ b/pkg/utilities/nttools/copyone/filetype.x @@ -0,0 +1,28 @@ +include "filetype.h" + +# FILETYPE -- Determine filetype of file + +int procedure filetype (file) + +char file # i: file name +#-- +int flag + +int is_image() + +begin + # Is_image is in the selector sublibrary of tbtables + # and is the recommended procedure for determining file + # type + + switch (is_image(file)) { + case ERR: + flag = UNKNOWN_FILE + case NO: + flag = TABLE_FILE + case YES: + flag = IMAGE_FILE + } + + return (flag) +end diff --git a/pkg/utilities/nttools/copyone/filetype.x.OLD b/pkg/utilities/nttools/copyone/filetype.x.OLD new file mode 100644 index 00000000..65e30293 --- /dev/null +++ b/pkg/utilities/nttools/copyone/filetype.x.OLD @@ -0,0 +1,61 @@ +include "filetype.h" + +# FILETYPE -- Determine the file type from the file name. Say the file type +# is unknown if the file cannot be accessed or the name is ambiguous. +# +# B.Simon Aug-13-87 First Code +# B.Simon Jan-24-92 Added salloc for extension + +int procedure filetype (fname) + +char fname[ARB] # i: file name +#-- +int ftype +pointer sp, extension, cluster + +int fnextn(), imaccess(), tabaccess(), access() + +begin + call smark (sp) + call salloc (extension, SZ_FNAME, TY_CHAR) # Added (BPS 01.24.92) + call salloc (cluster, SZ_FNAME, TY_CHAR) + + ftype = UNKNOWN_FILE + call imgcluster (fname, Memc[cluster], SZ_FNAME) + + if (access (Memc[cluster], 0, 0) == YES) { + + # File exists with specified name + + if (imaccess (Memc[cluster], READ_ONLY) == YES && + imaccess (Memc[cluster], NEW_FILE) == YES ) + + ftype = IMAGE_FILE + + else if (tabaccess (Memc[cluster], READ_ONLY) == YES) + + ftype = TABLE_FILE + + } else if (fnextn (Memc[cluster], Memc[extension], SZ_FNAME) == 0) { + + # File name does not contain an extension, + # try adding default extensions + + if (tabaccess (Memc[cluster], READ_ONLY) == YES && + imaccess (Memc[cluster], READ_ONLY) == YES ) + + ftype = UNKNOWN_FILE + + else if (imaccess (Memc[cluster], READ_ONLY) == YES) + + ftype = IMAGE_FILE + + else if (tabaccess (Memc[cluster], READ_ONLY) == YES) + + ftype = TABLE_FILE + + } + + call sfree (sp) + return (ftype) +end diff --git a/pkg/utilities/nttools/copyone/getimghdr.x b/pkg/utilities/nttools/copyone/getimghdr.x new file mode 100644 index 00000000..03dc9ced --- /dev/null +++ b/pkg/utilities/nttools/copyone/getimghdr.x @@ -0,0 +1,35 @@ +# GETIMGHDR -- Read a keyword from an image header into a string +# +# B.Simon 13-Aug-87 First Code +# B.Simon 12-Dec-94 Added error check +# B.Simon 21-Jul-97 Add extra check to work around imgftype bug + +procedure getimghdr (hd, keyword, maxch, value, keytype) + +pointer hd # i: Image descriptor +char keyword[ARB] # i: Name of header keyword +int maxch # i: Maximum length of keyword value +char value[ARB] # o: Keyword value +int keytype # o: Type of header keyword +#-- +int imgftype() +errchk imgstr + +begin + # Read image header keyword and get datatype + + call imgstr (hd, keyword, value, maxch) + keytype = imgftype (hd, keyword) + + # If boolean, convert to the standard names + # The check on value[2] is to work around a + # bug in imgftype() + + if (value[2] == EOS && keytype == TY_BOOL) + if (value[1] == 'T') + call strcpy ("yes", value, maxch) + else + call strcpy ("no", value, maxch) + + return +end diff --git a/pkg/utilities/nttools/copyone/gettabdat.x b/pkg/utilities/nttools/copyone/gettabdat.x new file mode 100644 index 00000000..66a6c215 --- /dev/null +++ b/pkg/utilities/nttools/copyone/gettabdat.x @@ -0,0 +1,111 @@ +include +define USRERR 1 + +# GETTABDAT -- Read an element from a table into a string +# +# B.Simon 17-Aug-1987 First Code +# Phil Hodge 15-May-2002 Add 'format' argument. ctowrd is a function. + +procedure gettabdat (hd, colname, rownum, maxch, format, value, undef, eltype) + +pointer hd # i: Table descriptor +char colname[ARB] # i: Table column name +int rownum # i: Table row number +int maxch # i: Maximum length of element value +bool format # i: Format the value using table print format? +char value[ARB] # o: Table element value +bool undef # o: Is table element undefined? +int eltype # o: Type of table element + +bool nullbuf[1] +int lendata, ip +pointer colptr[1] +pointer sp, errtxt, valbuf + +double dval[1] +real rval[1] +int ival[1] +bool bval[1] + +string badnamerr "Column name not found in table (%s)" +string unknown_type "Unknown data type in table" + +int tbcigi() +int junk, ctowrd() + +begin + # Allocate dynamic memory to hold strings + + call smark (sp) + call salloc (errtxt, SZ_LINE, TY_CHAR) + call salloc (valbuf, maxch, TY_CHAR) + + # Get the column pointer from the column name + + call tbcfnd (hd, colname, colptr, 1) + + # If the pointer is NULL, the column was not found + + if (colptr[1] == NULL) { + call sprintf (Memc[errtxt], SZ_LINE, badnamerr) + call pargstr (colname) + call error (USRERR, Memc[errtxt]) + } + + # Get the column data type. Store in eltype + + eltype = tbcigi (colptr[1], TBL_COL_DATATYPE) + if (eltype < 0) { + lendata = - eltype + eltype = TY_CHAR + } + + # Get the table element as a text string + + if (format || eltype == TY_CHAR) { + call tbrgtt (hd, colptr, Memc[valbuf], nullbuf, maxch, 1, rownum) + } else { + switch (eltype) { + case TY_BOOL : + call tbrgtb (hd, colptr, bval, nullbuf, 1, rownum) + if (bval[1]) + call strcpy ("yes", Memc[valbuf], maxch) + else + call strcpy ("no", Memc[valbuf], maxch) + case TY_SHORT,TY_INT : + call tbrgti (hd, colptr, ival, nullbuf, 1, rownum) + call sprintf (Memc[valbuf], maxch, "%d") + call pargi (ival) + case TY_REAL : + call tbrgtr (hd, colptr, rval, nullbuf, 1, rownum) + call sprintf (Memc[valbuf], maxch, "%15.7g") + call pargr (rval) + case TY_DOUBLE : + call tbrgtd (hd, colptr, dval, nullbuf, 1, rownum) + call sprintf (Memc[valbuf], maxch, "%25.16g") + call pargd (dval) + default : + call error (1, unknown_type) + } + } + + if (eltype == TY_CHAR) { + + # Just do a straight copy if the element is a string + + call strcpy (Memc[valbuf], value, maxch) + + } else{ + + # Otherwise, strip whitespace from element value + + ip = 1 + junk = ctowrd (Memc[valbuf], ip, value, maxch) + + } + + undef = nullbuf[1] + call sfree (sp) + + return +end diff --git a/pkg/utilities/nttools/copyone/gettabhdr.x b/pkg/utilities/nttools/copyone/gettabhdr.x new file mode 100644 index 00000000..4e9812bc --- /dev/null +++ b/pkg/utilities/nttools/copyone/gettabhdr.x @@ -0,0 +1,55 @@ +# GETTABHDR -- Read a keyword from an table header into a string +# +# B.Simon 14-Aug-87 First Code +# B.Simon 12-Dec-94 Added error check + +procedure gettabhdr (hd, keyword, maxch, value, keytype) + +pointer hd # i: Table descriptor +char keyword[ARB] # i: Name of header keyword +int maxch # i: Maximum length of keyword value +char value[ARB] # o: Keyword value +int keytype # o: Type of header keyword +#-- +int ip +pointer keyval, sp + +int tabhdrtyp() +errchk tbhgtt + +begin + call smark (sp) + call salloc (keyval, maxch, TY_CHAR) + + # Read table header keyword and get datatype + + call tbhgtt (hd, keyword, Memc[keyval], maxch) + keytype = tabhdrtyp (hd, keyword) + + if (keytype == TY_CHAR) { + + # Just do a straight copy if the keyword is a string + + call strcpy (Memc[keyval], value, maxch) + + } else{ + + # Otherwise, strip whitespace from keyword value + + ip = 1 + call ctowrd (Memc[keyval], ip, value, maxch) + + # If boolean, convert to the standard names + + if (keytype == TY_BOOL) { + + if (value[1] == '1') + call strcpy ("yes", value, maxch) + else + call strcpy ("no", value, maxch) + } + } + + call sfree (sp) + return +end diff --git a/pkg/utilities/nttools/copyone/isdouble.x b/pkg/utilities/nttools/copyone/isdouble.x new file mode 100644 index 00000000..4ee128cc --- /dev/null +++ b/pkg/utilities/nttools/copyone/isdouble.x @@ -0,0 +1,37 @@ +include +include + +# IS_DOUBLE -- Check to see if a real number is actually double precision +# +# B.Simon 15-Dec-94 First Code + +int procedure is_double (token) + +char token[ARB] # i: token containing number +#-- +int ic, ndigit + +begin + # Count number of digits in mantissa and look for D exponent + + ndigit = 0 + for (ic = 1; token[ic] != EOS; ic = ic + 1) { + if (token[ic] == 'D' || token[ic] == 'd') { + return (TY_DOUBLE) + + } else if (token[ic] == 'E' || token[ic] == 'e') { + break + } + + if (IS_DIGIT(token[ic])) + ndigit = ndigit + 1 + } + + # If no D exponent, set the type according to the number of digits + + if (ndigit > NDIGITS_RP) { + return (TY_DOUBLE) + } else { + return (TY_REAL) + } +end diff --git a/pkg/utilities/nttools/copyone/keypar.x b/pkg/utilities/nttools/copyone/keypar.x new file mode 100644 index 00000000..0a5c9423 --- /dev/null +++ b/pkg/utilities/nttools/copyone/keypar.x @@ -0,0 +1,109 @@ +include "filetype.h" + +define SZ_KEYWORD 64 +define USRERR 1 + +# KEYPAR -- Transfer header keyword to IRAF parameter +# +# B.Simon 14-Aug-87 First Code +# B.Simon 14-Dec-94 Added error checking + +procedure t_keypar() + +#-- +pointer input # Name of file containing header keyword +pointer keyword # Name of header keyword +bool silent # Don't print warning message +pointer value # IRAF parameter value + +bool found +int ftype, keytype, junk +pointer errtxt, sp, hd + +string unfilerr "Header file name not found or ambiguous (%s)" + +bool clgetb() +int filetype(), errget() +pointer immap(), tbtopn() + +begin + # Allocate storage for character strings + + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (keyword, SZ_KEYWORD, TY_CHAR) + call salloc (value, SZ_KEYWORD, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Read input parameters + + call clgstr ("input", Memc[input], SZ_FNAME) + call clgstr ("keyword", Memc[keyword], SZ_KEYWORD) + silent = clgetb ("silent") + + ftype = filetype (Memc[input]) + + if (ftype == IMAGE_FILE) { + + # Read image header keyword and get datatype + + found = true + hd = immap (Memc[input], READ_ONLY, NULL) + iferr { + call getimghdr (hd, Memc[keyword], SZ_KEYWORD, + Memc[value], keytype) + } then { + junk = errget (Memc[errtxt], SZ_LINE) + call xer_reset + + keytype = TY_CHAR + Memc[value] = EOS + found = false + + if (! silent) { + call eprintf ("Warning: %s\n") + call pargstr (Memc[errtxt]) + } + } + call imunmap (hd) + + } else if (ftype == TABLE_FILE) { + + # Read table header keyword and get datatype + + found = true + hd = tbtopn (Memc[input], READ_ONLY, NULL) + iferr { + call gettabhdr (hd, Memc[keyword], SZ_KEYWORD, + Memc[value], keytype) + } then { + junk = errget (Memc[errtxt], SZ_LINE) + call xer_reset + + keytype = TY_CHAR + Memc[value] = EOS + found = false + + if (! silent) { + call eprintf ("Warning: %s\n") + call pargstr (Memc[errtxt]) + } + } + call tbtclo (hd) + + } else { + + call sprintf (Memc[errtxt], SZ_LINE, unfilerr) + call pargstr (Memc[input]) + call error (USRERR, Memc[errtxt]) + + } + + # Write output parameters and free string storage + + call addslash (Memc[value], SZ_KEYWORD) + call clpstr ("value", Memc[value]) + call clputb ("found", found) + call sfree(sp) + return +end diff --git a/pkg/utilities/nttools/copyone/keytab.x b/pkg/utilities/nttools/copyone/keytab.x new file mode 100644 index 00000000..38577404 --- /dev/null +++ b/pkg/utilities/nttools/copyone/keytab.x @@ -0,0 +1,113 @@ +include +include "filetype.h" + +define SZ_KEYWORD 64 +define USRERR 1 + +# KEYTAB -- Transfer a header keyword to a table element +# +# B.Simon 17-Aug-87 First Code +# B.Simon 14-Dec-94 Added error checking + +procedure t_keytab () + +#-- +pointer input # Name of file containing header keyword +pointer keyword # Name of header keyword +pointer table # Name of table +pointer column # Name of column +int row # Row number of element in the table +bool silent # Don't print warning message + +bool undef +int ftype, keytype, junk +pointer value, errtxt, sp, hd + +string unfilerr "Header file name not found or ambiguous (%s)" + +bool clgetb() +int clgeti(), filetype(), errget() +pointer immap(), tbtopn() + +begin + # Allocate storage for character strings + + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (keyword, SZ_KEYWORD, TY_CHAR) + call salloc (table, SZ_FNAME, TY_CHAR) + call salloc (column, SZ_COLNAME, TY_CHAR) + call salloc (value, SZ_KEYWORD, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Read input parameters + + call clgstr ("input", Memc[input], SZ_FNAME) + call clgstr ("keyword", Memc[keyword], SZ_KEYWORD) + call clgstr ("table", Memc[table], SZ_FNAME) + call clgstr ("column", Memc[column], SZ_COLNAME) + row = clgeti ("row") + silent = clgetb ("silent") + + undef = false + ftype = filetype (Memc[input]) + + if (ftype == IMAGE_FILE) { + + # Read image header keyword and get datatype + + hd = immap (Memc[input], READ_ONLY, NULL) + iferr { + call getimghdr (hd, Memc[keyword], SZ_KEYWORD, + Memc[value], keytype) + } then { + junk = errget (Memc[errtxt], SZ_LINE) + call xer_reset + undef = true + + if (! silent) { + call eprintf ("Warning: %s\n") + call pargstr (Memc[errtxt]) + } + } + call imunmap (hd) + + } else if (ftype == TABLE_FILE) { + + # Read table header keyword and get datatype + + hd = tbtopn (Memc[input], READ_ONLY, NULL) + iferr { + call gettabhdr (hd, Memc[keyword], SZ_KEYWORD, + Memc[value], keytype) + } then { + junk = errget (Memc[errtxt], SZ_LINE) + call xer_reset + undef = true + + if (! silent) { + call eprintf ("Warning: %s\n") + call pargstr (Memc[errtxt]) + } + } + call tbtclo (hd) + + } else { + + call sprintf (Memc[errtxt], SZ_LINE, unfilerr) + call pargstr (Memc[input]) + call error (USRERR, Memc[errtxt]) + + } + + # Write the table element according to its datatype + + hd = tbtopn (Memc[table], READ_WRITE, NULL) + call puttabdat (hd, Memc[column], row, Memc[value], undef, keytype) + call tbtclo (hd) + + # Free string storage + + call sfree (sp) + return +end diff --git a/pkg/utilities/nttools/copyone/mkpkg b/pkg/utilities/nttools/copyone/mkpkg new file mode 100644 index 00000000..815e2d9d --- /dev/null +++ b/pkg/utilities/nttools/copyone/mkpkg @@ -0,0 +1,29 @@ +# Update the KEYPAR, KEYTAB, PARKEY, PARTAB, TABKEY, TABPAR task code +# in the ttools package library +# Author: B.Simon, 25-NOV-1987 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + addslash.x + datatype.x + filetype.x filetype.h + getimghdr.x + gettabdat.x + gettabhdr.x + isdouble.x + keypar.x filetype.h + keytab.x filetype.h + parkey.x filetype.h + partab.x + putimghdr.x + puttabdat.x + puttabhdr.x + tabaccess.x + tabhdrtyp.x + tabkey.x filetype.h + tabpar.x + ; diff --git a/pkg/utilities/nttools/copyone/parkey.x b/pkg/utilities/nttools/copyone/parkey.x new file mode 100644 index 00000000..c473ee80 --- /dev/null +++ b/pkg/utilities/nttools/copyone/parkey.x @@ -0,0 +1,71 @@ +include "filetype.h" + +define SZ_KEYWORD 64 +define USRERR 1 + +# PARKEY -- Transfer IRAF parameter to header keyword +# +# B.Simon 14-Aug-87 First Code + +procedure t_parkey() + +pointer value # IRAF parameter value +pointer output # Name of file containing header keyword +pointer keyword # Name of header keyword +bool add # Is it OK to add a new keyword? + +int ftype, keytype +pointer errtxt, sp, hd + +string unfilerr "Header file name not found or ambiguous (%s)" + +bool clgetb() +int filetype(), datatype() +pointer immap(), tbtopn() + +begin + # Allocate storage for character strings + + call smark (sp) + call salloc (value, SZ_KEYWORD, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (keyword, SZ_KEYWORD, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Read parameters + + call clgstr ("value", Memc[value], SZ_KEYWORD) + call clgstr ("output", Memc[output], SZ_FNAME) + call clgstr ("keyword", Memc[keyword], SZ_KEYWORD) + add = clgetb("add") + + ftype = filetype (Memc[output]) + keytype = datatype (Memc[value]) + + if (ftype == IMAGE_FILE) { + + # Write image header keyword + + hd = immap (Memc[output], READ_WRITE, NULL) + call putimghdr (hd, Memc[keyword], Memc[value], keytype, add) + call imunmap (hd) + + } else if (ftype == TABLE_FILE) { + + # Write table header keyword + + hd = tbtopn (Memc[output], READ_WRITE, NULL) + call puttabhdr (hd, Memc[keyword], Memc[value], keytype, add) + call tbtclo (hd) + + } else { + + call sprintf (Memc[errtxt], SZ_LINE, unfilerr) + call pargstr (Memc[output]) + call error (USRERR, Memc[errtxt]) + + } + + call sfree(sp) + return +end diff --git a/pkg/utilities/nttools/copyone/partab.x b/pkg/utilities/nttools/copyone/partab.x new file mode 100644 index 00000000..19505049 --- /dev/null +++ b/pkg/utilities/nttools/copyone/partab.x @@ -0,0 +1,51 @@ +include +define SZ_KEYWORD 64 + +# PARTAB -- Transfer an IRAF parameter value to a table element +# +# B.Simon 17-Aug-87 First Code + +procedure t_partab () + +pointer value # Value of table element +pointer table # Name of table +pointer column # Name of column +int row # Row number of element in the table + +bool undef +int eltype +pointer sp, hd + +bool streq() +int clgeti(), datatype() +pointer tbtopn() + +begin + # Allocate storage for character strings + + call smark (sp) + call salloc (value, SZ_KEYWORD, TY_CHAR) + call salloc (table, SZ_FNAME, TY_CHAR) + call salloc (column, SZ_COLNAME, TY_CHAR) + + # Read input parameters + + call clgstr ("value", Memc[value], SZ_KEYWORD) + call clgstr ("table", Memc[table], SZ_FNAME) + call clgstr ("column", Memc[column], SZ_COLNAME) + row = clgeti ("row") + + eltype = datatype (Memc[value]) + undef = streq (Memc[value], "INDEF") + + # Write the table element according to its datatype + + hd = tbtopn (Memc[table], READ_WRITE, NULL) + call puttabdat (hd, Memc[column], row, Memc[value], undef, eltype) + call tbtclo (hd) + + # Free string storage + + call sfree (sp) + return +end diff --git a/pkg/utilities/nttools/copyone/putimghdr.x b/pkg/utilities/nttools/copyone/putimghdr.x new file mode 100644 index 00000000..bc0b34c6 --- /dev/null +++ b/pkg/utilities/nttools/copyone/putimghdr.x @@ -0,0 +1,118 @@ +define USRERR 1 + +# PUTIMGHDR -- Put a keyword given as a string in an image header +# +# B.Simon 14-Aug-87 First Code +# B.Simon 27-Jul-94 Fix bug in addition of double +# B.Simon 21-Jul-97 Workaround for imgftype bug + +procedure putimghdr (hd, keyword, value, keytype, add) + +pointer hd # i: Image descriptor +char keyword[ARB] # i: Keyword to put +char value[ARB] # i: Keyword value +int keytype # i: Keyword type +bool add # i: Is adding a new keyword legal? +#-- +bool bvalue +double dvalue +int ip, junk, hdrtype +pointer sp, rp, keyval, errtxt + +string badtyperr "Type mismatch in header keyword (%s)" +string notadderr "Keyword not found in header (%s)" + +int ctod(), idb_findrecord(), imgftype(), stridx() + +begin + + call smark (sp) + call salloc (keyval, SZ_FNAME, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Convert keyword value to a double + + ip = 1 + junk = ctod (value, ip, dvalue) + + # If keyword is already in the image header + + if (idb_findrecord (hd, keyword, rp) > 0) { + + hdrtype = imgftype (hd, keyword) + + # Extra test to work around bug in imgftype + + if (hdrtype == TY_BOOL) { + call imgstr(hd, keyword, Memc[keyval], SZ_FNAME) + if (Memc[keyval+1] != EOS) + hdrtype = TY_CHAR + } + + # Check for illegal type conversions + + if ((hdrtype == TY_BOOL && keytype != TY_BOOL) || + (!(hdrtype == keytype || hdrtype == TY_CHAR) && + (keytype == TY_BOOL || keytype == TY_CHAR) ) ) { + + call sprintf (Memc[errtxt], SZ_LINE, badtyperr) + call pargstr (keyword) + call error (USRERR, Memc[errtxt]) + + } + + # Use the proper procedure to write the new keyword value + + switch (hdrtype) { + case TY_BOOL : + bvalue = stridx (value[1], "TtYy") > 0 + call imputb (hd, keyword, bvalue) + case TY_CHAR : + call impstr (hd, keyword, value) + case TY_SHORT : + call imputs (hd, keyword, short(dvalue)) + case TY_INT : + call imputi (hd, keyword, int(dvalue)) + case TY_LONG : + call imputl (hd, keyword, long(dvalue)) + case TY_REAL : + call imputr (hd, keyword, real(dvalue)) + case TY_DOUBLE : + call imputd (hd, keyword, dvalue) + } + + } else { + + # Check to see if it legal to add a new keyword + + if (! add) { + call sprintf (Memc[errtxt], SZ_LINE, notadderr) + call pargstr (keyword) + call error (USRERR, Memc[errtxt]) + } + + # Create the new keyword and set its value + + switch (keytype) { + case TY_BOOL : + bvalue = stridx (value[1], "TtYy") > 0 + call imaddb (hd, keyword, bvalue) + case TY_CHAR : + call imastr (hd, keyword, value) + case TY_SHORT : + call imadds (hd, keyword, short(dvalue)) + case TY_INT : + call imaddi (hd, keyword, int(dvalue)) + case TY_LONG : + call imaddl (hd, keyword, long(dvalue)) + case TY_REAL : + call imaddr (hd, keyword, real(dvalue)) + case TY_DOUBLE : + call imaddd (hd, keyword, dvalue) + } + + } + + call sfree (sp) + return +end diff --git a/pkg/utilities/nttools/copyone/puttabdat.x b/pkg/utilities/nttools/copyone/puttabdat.x new file mode 100644 index 00000000..b5742f98 --- /dev/null +++ b/pkg/utilities/nttools/copyone/puttabdat.x @@ -0,0 +1,106 @@ +include +define USRERR 1 + +# PUTTABDAT -- Write a value passed as a string into a table element +# +# B.Simon 17-Aug-87 First Code + +procedure puttabdat (hd, colname, rownum, value, undef, eltype) + +pointer hd # i: Table descriptor +char colname[ARB] # i: Table column name +int rownum # i: Table row number +char value[ARB] # i: Table element value +bool undef # i: Is table element undefined? +int eltype # i: Type of table element + +bool bvalue[1] +double dvalue[1] +int ivalue[1] +pointer colptr[1] +real rvalue[1] + +int coltype, lendata, ip, junk, maxch +pointer sp, errtxt + +string badtyperr "Type mismatch in table column (%s)" +string badnamerr "Column name not found in table (%s)" + +int ctod() +int stridx(), strlen(), tbcigi() + +begin + # Allocate dynamic memory to hold strings + + call smark (sp) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Get the column pointer from the column name + + call tbcfnd (hd, colname, colptr, 1) + + # If the pointer is NULL, the column was not found + + if (colptr[1] == NULL) { + call sprintf (Memc[errtxt], SZ_LINE, badnamerr) + call pargstr (colname) + call error (USRERR, Memc[errtxt]) + } + + # Get the column data type. Store in coltype + + coltype = tbcigi (colptr[1], TBL_COL_DATATYPE) + if (coltype < 0) { + lendata = - coltype + coltype = TY_CHAR + } + + if (undef) + + # Set table element to undefined + + call tbrudf (hd, colptr, 1, rownum) + + else { + + # Convert element value to a double + + ip = 1 + junk = ctod (value, ip, dvalue[1]) + + # Check for illegal type conversions + + if ((coltype == TY_BOOL && eltype != TY_BOOL) || + (!(coltype == eltype || coltype == TY_CHAR) && + (eltype == TY_BOOL || eltype == TY_CHAR) ) ) { + + call sprintf (Memc[errtxt], SZ_LINE, badtyperr) + call pargstr (colname) + call error (USRERR, Memc[errtxt]) + + } + + # Use the proper procedure to write the new element value + + switch (coltype) { + case TY_BOOL : + bvalue[1] = stridx (value[1], "TtYy") > 0 + call tbrptb (hd, colptr, bvalue, 1, rownum) + case TY_CHAR : + maxch = strlen (value) + 1 + call tbrptt (hd, colptr, value, maxch, 1, rownum) + case TY_SHORT,TY_INT,TY_LONG : + ivalue[1] = int (dvalue[1]) + call tbrpti (hd, colptr, ivalue, 1, rownum) + case TY_REAL : + rvalue[1] = real (dvalue[1]) + call tbrptr (hd, colptr, rvalue, 1, rownum) + case TY_DOUBLE : + call tbrptd (hd, colptr, dvalue, 1, rownum) + } + } + + call sfree (sp) + + return +end diff --git a/pkg/utilities/nttools/copyone/puttabhdr.x b/pkg/utilities/nttools/copyone/puttabhdr.x new file mode 100644 index 00000000..ffcb6643 --- /dev/null +++ b/pkg/utilities/nttools/copyone/puttabhdr.x @@ -0,0 +1,104 @@ +define USRERR 1 + +# PUTTABHDR -- Put a keyword given as a string in a table header +# +# B.Simon 14-Aug-87 First Code +# B.Simon 27-Jul-94 Fix bug in addition of double +# B.Simon 10-Nov-95 Add check for history keyword + +procedure puttabhdr (hd, keyword, value, keytype, add) + +pointer hd # i: Table descriptor +char keyword[ARB] # i: Keyword to put +char value[ARB] # i: Keyword value +int keytype # i: Keyword type +bool add # i: Is adding a new keyword legal? +#-- +bool bvalue +double dvalue +int ip, junk, hdrtype, keynum +pointer sp, errtxt + +string badtyperr "Type mismatch in header keyword (%s)" +string notadderr "Keyword not found in header (%s)" + +bool tbhisc() +int ctod(), tabhdrtyp(), stridx() + +begin + + call smark (sp) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Convert keyword value to a double + + ip = 1 + junk = ctod (value, ip, dvalue) + + # If keyword is not already in the table header + # or this is a history keyword + + call tbhfkw (hd, keyword, keynum) + if ( keynum == 0 || tbhisc (keyword)) { + + # Check to see if it legal to add a new keyword + + if (! add) { + call sprintf (Memc[errtxt], SZ_LINE, notadderr) + call pargstr (keyword) + call error (USRERR, Memc[errtxt]) + } + + # Create the new keyword and set its value + + switch (keytype) { + case TY_BOOL : + bvalue = stridx (value[1], "TtYy") > 0 + call tbhadb (hd, keyword, bvalue) + case TY_CHAR : + call tbhadt (hd, keyword, value) + case TY_SHORT,TY_INT,TY_LONG : + call tbhadi (hd, keyword, int(dvalue)) + case TY_REAL : + call tbhadr (hd, keyword, real(dvalue)) + case TY_DOUBLE : + call tbhadd (hd, keyword, dvalue) + } + + } else { + + hdrtype = tabhdrtyp (hd, keyword) + + # Check for illegal type conversions + + if ((hdrtype == TY_BOOL && keytype != TY_BOOL) || + (!(hdrtype == keytype || hdrtype == TY_CHAR) && + (keytype == TY_BOOL || keytype == TY_CHAR) ) ) { + + call sprintf (Memc[errtxt], SZ_LINE, badtyperr) + call pargstr (keyword) + call error (USRERR, Memc[errtxt]) + + } + + # Use the proper procedure to write the new keyword value + + switch (hdrtype) { + case TY_BOOL : + bvalue = stridx (value[1], "TtYy") > 0 + call tbhptb (hd, keyword, bvalue) + case TY_CHAR : + call tbhptt (hd, keyword, value) + case TY_SHORT,TY_INT,TY_LONG : + call tbhpti (hd, keyword, int(dvalue)) + case TY_REAL : + call tbhptr (hd, keyword, real(dvalue)) + case TY_DOUBLE : + call tbhptd (hd, keyword, dvalue) + } + + } + + call sfree (sp) + return +end diff --git a/pkg/utilities/nttools/copyone/tabaccess.x b/pkg/utilities/nttools/copyone/tabaccess.x new file mode 100644 index 00000000..93c93337 --- /dev/null +++ b/pkg/utilities/nttools/copyone/tabaccess.x @@ -0,0 +1,19 @@ +# TABACCESS -- Test to see if an table is accessible with the given access +# mode. Return the result of the test as YES or NO. +# +# B.Simon 12-Aug-87 First Code +# B.Simon 19-Jun-95 Revised to use tbtacc + +int procedure tabaccess (tablename, acmode) + +char tablename[ARB] # i: table file name +int acmode # i: access mode +#-- +int tbtacc() + +begin + if (acmode == NEW_FILE || acmode == NEW_COPY) + return (YES) + + return (tbtacc (tablename)) +end diff --git a/pkg/utilities/nttools/copyone/tabhdrtyp.x b/pkg/utilities/nttools/copyone/tabhdrtyp.x new file mode 100644 index 00000000..7d65e89f --- /dev/null +++ b/pkg/utilities/nttools/copyone/tabhdrtyp.x @@ -0,0 +1,34 @@ +include +define USRERR 1 + +# TABHDRTYP -- Return the type of a table header keyword +# +# B. Simon 12-Aug-87 First Code +# Phil Hodge 9-Mar-89 Change to itype in calling sequence of tbhfkr. + +int procedure tabhdrtyp (tp, keyword) + +pointer tp # i: Table descriptor +char keyword[ARB] # i: Header keyword +#-- +int parnum, itype +pointer sp, keyval, errtxt + +string nokeyfnd "Keyword not found (%s)" + +begin + call smark (sp) + call salloc (keyval, SZ_PARREC, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + call tbhfkr (tp, keyword, itype, Memc[keyval], parnum) + + if (parnum == 0) { + call sprintf (Memc[errtxt], SZ_LINE, nokeyfnd) + call pargstr (keyword) + call error (USRERR, Memc[errtxt]) + } + + call sfree (sp) + return (itype) +end diff --git a/pkg/utilities/nttools/copyone/tabkey.x b/pkg/utilities/nttools/copyone/tabkey.x new file mode 100644 index 00000000..9efd2329 --- /dev/null +++ b/pkg/utilities/nttools/copyone/tabkey.x @@ -0,0 +1,94 @@ +include +include "filetype.h" +define SZ_KEYWORD 64 +define USRERR 1 + +# TABKEY -- Transfer a table element to a header keyword +# +# B.Simon 17-Aug-87 First Code +# B.Simon 24-Jan-92 Added salloc for errtxt +# Phil Hodge 15-May-2002 Add 'format' argument to gettabdat. + +procedure t_tabkey () + +pointer table # Name of table +pointer column # Name of column +int row # Row number of element in the table +pointer output # Name of file containing header keyword +pointer keyword # Name of header keyword +bool add # Is it OK to add a new keyword? + +bool undef +bool format # Format the value using table print format? +int ftype, eltype +pointer sp, hd, value, errtxt + +string undeferr "Table element is undefined" +string unfilerr "Header file name not found or ambiguous (%s)" + +bool clgetb() +int clgeti(), filetype() +pointer immap(), tbtopn() + +begin + # Allocate storage for character strings + + call smark (sp) + call salloc (table, SZ_FNAME, TY_CHAR) + call salloc (column, SZ_COLNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (keyword, SZ_KEYWORD, TY_CHAR) + call salloc (value, SZ_KEYWORD, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) # Added (BPS 01.24.92) + + # Read input parameters + + call clgstr ("table", Memc[table], SZ_FNAME) + call clgstr ("column", Memc[column], SZ_COLNAME) + row = clgeti ("row") + call clgstr ("output", Memc[output], SZ_FNAME) + call clgstr ("keyword", Memc[keyword], SZ_KEYWORD) + add = clgetb("add") + + # Read the table element as a character string + + format = false + hd = tbtopn (Memc[table], READ_ONLY, NULL) + call gettabdat (hd, Memc[column], row, SZ_KEYWORD, format, + Memc[value], undef, eltype) + call tbtclo (hd) + + # It is an error to try to write an undefined value to the header + + if (undef) + call error (USRERR, undeferr) + + ftype = filetype (Memc[output]) + + if (ftype == IMAGE_FILE) { + + # Write image header keyword + + hd = immap (Memc[output], READ_WRITE, NULL) + call putimghdr (hd, Memc[keyword], Memc[value], eltype, add) + call imunmap (hd) + + } else if (ftype == TABLE_FILE) { + + # Write table header keyword + + hd = tbtopn (Memc[output], READ_WRITE, NULL) + call puttabhdr (hd, Memc[keyword], Memc[value], eltype, add) + call tbtclo (hd) + + } else { + + call sprintf (Memc[errtxt], SZ_LINE, unfilerr) + call pargstr (Memc[output]) + call error (USRERR, Memc[errtxt]) + + } + + call sfree(sp) + return +end diff --git a/pkg/utilities/nttools/copyone/tabpar.x b/pkg/utilities/nttools/copyone/tabpar.x new file mode 100644 index 00000000..a4f452c3 --- /dev/null +++ b/pkg/utilities/nttools/copyone/tabpar.x @@ -0,0 +1,54 @@ +include +define SZ_KEYWORD 64 + +# TABPAR -- Transfer a table element to an IRAF parameter +# +# B.Simon 17-Aug-1987 First Code +# Phil Hodge 15-May-2002 Add 'format' parameter. + +procedure t_tabpar () + +pointer table # Name of table +pointer column # Name of column +int row # Row number of element in the table +bool format # Format the value using table print format? +pointer value # Value of table element +bool undef # Is table element undefined? + +int eltype +pointer sp, hd + +bool clgetb() +int clgeti() +pointer tbtopn() + +begin + # Allocate storage for character strings + + call smark (sp) + call salloc (table, SZ_FNAME, TY_CHAR) + call salloc (column, SZ_COLNAME, TY_CHAR) + call salloc (value, SZ_KEYWORD, TY_CHAR) + + # Read input parameters + + call clgstr ("table", Memc[table], SZ_FNAME) + call clgstr ("column", Memc[column], SZ_COLNAME) + row = clgeti ("row") + format = clgetb ("format") + + # Read the table element as a character string + + hd = tbtopn (Memc[table], READ_ONLY, NULL) + call gettabdat (hd, Memc[column], row, SZ_KEYWORD, format, + Memc[value], undef, eltype) + call tbtclo (hd) + + # Write output parameters and free string storage + + call addslash (Memc[value], SZ_KEYWORD) + call clpstr ("value", Memc[value]) + call clputb ("undef", undef) + call sfree (sp) + return +end diff --git a/pkg/utilities/nttools/doc/axispar.hlp b/pkg/utilities/nttools/doc/axispar.hlp new file mode 100644 index 00000000..d2a8dcbc --- /dev/null +++ b/pkg/utilities/nttools/doc/axispar.hlp @@ -0,0 +1,138 @@ +.help axispar Jul93 tables +.ih +NAME +pltpar -- Edit the parameter set that describes axis attributes. +.ih +USAGE +pltpar +.ih +DESCRIPTION +The 'axispar' parameters specify the attributes of plot axes. + +Note that this is a pset, not an executable task; it defines a set of +parameters used by other tasks. Invoking the pset by name runs +'eparam' on the parameter set, allowing the user to modify the +parameters. Alternatively, the parameters may be modified on the +command line by specifying the pset name and parameter name, for +example, the user can type "pltpar.pointmode=yes" to set only the +'pointmode' parameter. Parameters can also be edited by using +'eparam' on the calling task (e.g., by typing "eparam sgraph"), in +which case, 'pltpar' will appear as one of the task parameters; the +'pltpar' parameters may then be edited by positioning the cursor on +the line containing the pset name and typing ":e". After editing +the pset parameters, type Control-Z (or ":q") +to return to the main task parameter menu. +.ih +PARAMETERS +.ls (wl = 0.) [real] +Left world X-coordinate if not autoscaling. +.le +.ls (wr = 0.) [real] +Right world X-coordinate if not autoscaling. +.le +.ls (wb = 0.) [real] +Lower world Y-coordinate if not autoscaling. +.le +.ls (wt = 0.) [real] +Upper world Y-coordinate if not autoscaling. +.le +.ls (xflip = no) [boolean] +Flip the autoscaled X axis? +.le +.ls (yflip = no) [boolean] +Flip the autoscaled Y axis? +.le +.ls (transpose = no) [boolean] +Transpose the X and Y axes of the plot? If 'transpose = no', the +horizontal axis will have the X values or pixel number. +.le +.ls (logx = no) [boolean] +Scale the X axis logarithmically? +.le +.ls (logy = no) [boolean] +Scale the Y axis logarithmically? +.le +.ls (rejectlog = yes) [boolean] +Replace invalid logarithmic values with 'INDEF'? Invalid values will +be ignored in scaling and plotting. +.le +.ls (box = yes) [boolean] +Draw the box containing the axes and labels around the edge of the +window? +.le +.ls (ticklabels = yes) [boolean] +Label major tick marks? +.le +.ls (grid = no) [boolean] +Draw grid lines on the plot? +.le +.ls (xlabel) [string] +X-axis label. +.le +.ls (ylabel) [string] +Y-axis label. +.le +.ls (title = imtitle) [string] +The plot title may consist of one or two lines of text. If the +parameter 'sysid' is set to "yes", then the first line of the title is +a standard system-supplied string containing the user's name, date, +etc. If the 'title' parameter contains the string "imtitle" (the +default), then the plot title will contain a line made up from the +input file, image, or table name. The user can supply an optional +string for the 'title' parameter--this string will replace the string +resulting from the "imtitle" specification. +.le +.ls (sysid = yes) [boolean] +Include standard system information in the plot title? If the 'sysid' +parameter is "yes", then a string including the user's name, date, host +name, etc. is included in the plot title. +.le +.ls (lintran = no) [boolean] +Perform a linear transformation of the X axis? +.le +.ls (p1 = 0.) [real] +Starting input pixel value if 'lintran = yes'. +.le +.ls (p2 = 0.) [real] +Ending input pixel value if 'lintran = yes'. +.le +.ls (q1 = 0.) [real] +Starting output pixel value if 'lintran = yes'. +.le +.ls (q2 = 1.) [real] +Ending output pixel value if 'lintran = yes'. +.le +.ls (majrx = 5) [integer] +Number of major divisions along the X grid. +.le +.ls (minrx = 5) [integer] +Number of minor divisions along the X grid. +.le +.ls (majry = 5) [integer] +Number of major divisions along the Y grid. +.le +.ls (minry = 5) [integer] +Number of minor divisions along the Y grid. +.le +.ls (round = no) [boolean] +Round axes to nice values? (Values at tick marks will be significant, +based on scale of the data.) +.le +.ls (margin = INDEF) [real, min = 0, max = 1] +The margin between the viewport edges (plot axes) and the limits of the +plotted curve(s) as a fraction of the viewport (NDC). If 'margin = +INDEF', the default, a 2.5% margin will apply. That is, the plotted +curve(s) will be inset .025 times the size of the viewport. Set +'margin = 0' to plot curves to the axes. +.le +.ls (version = 17August92) [string] +Date the task was installed. This should not be changed by the user. +.le +.ih +EXAMPLES +.ih +BUGS +.ih +SEE ALSO +sgraph, pltpar, dvpar +.endhelp diff --git a/pkg/utilities/nttools/doc/dvpar.hlp b/pkg/utilities/nttools/doc/dvpar.hlp new file mode 100644 index 00000000..94bb4971 --- /dev/null +++ b/pkg/utilities/nttools/doc/dvpar.hlp @@ -0,0 +1,68 @@ +.help dvpar Jul93 tables +.ih +NAME +dvpar -- Edit the parameter set that describes the graphics device. +.ih +USAGE +dvpar +.ih +DESCRIPTION +The 'dvpar' parameter set (pset) specifies device-related parameters. +These include the device name, whether plots should be appended to +existing plots, and the edges of the device viewport--that part of the +display device on which to draw the plot. + +Note that this is a parameter set (pset)--not an executable task. That +means that if the task is invoked by name on the command line, it will +start the 'eparam' task to edit the 'dvpar' parameters. Individual +parameters may be assigned using CL assignment statements from the +command line, or through the task parameters for 'fieldplot'. +.ih +PARAMETERS +.ls (device = "stdgraph") [string] +The graphics device name. The default, "stdgraph", uses the CL +environment parameter `stdgraph' to find the device name. For +example, if you are using gterm in SunView, you could have set +`stdgraph=gterm' or `device=gterm'. To overlay graphics on an image +display, use an "imd" device, "imdr" for red, "imdg" for green, etc. +.le +.ls (append = no) [boolean] +Append the graph to an existing plot? +.le +.ls (left = 0) [real, min = 0, max = 1] +The NDC coordinates of the left edge of the plot. +.le +.ls (right = 0) [real, min = 0, max = 1] +The NDC coordinates of the right edge of the plot. +.le +.ls (bottom = 0) [real, min = 0, max = 1] +The NDC coordinates of the bottom edge of the plot. +.le +.ls (top = 0) [real, min = 0, max = 1] +The NDC coordinates of the top edge of the plot. +.le +.ls (fill = yes) [boolean] +Fill the viewport? + +If set to "yes", the plot will fill the area specified by +the 'left', 'right', 'bottom', and 'top' viewport parameters. Otherwise, the +shape of the plot will reflect the aspect of the input data, but will +not be larger than the specified viewport. Note that this does not +apply to all tasks using the 'dvpar' pset. +.le +.ls (coords) [*gcur] +Graphics cursor file. +This is used if the task supports interaction via the graphics cursor. +.le +.ls (image_coord) [*imcur] +Used if the task supports interaction via the image display cursor. +.le +.ih +EXAMPLES +.ih +BUGS +.ih +SEE ALSO +fieldplot, newcont, sgraph, siaper, wcslab, +cursor, plot +.endhelp diff --git a/pkg/utilities/nttools/doc/gtedit.hlp b/pkg/utilities/nttools/doc/gtedit.hlp new file mode 100644 index 00000000..6ce396cc --- /dev/null +++ b/pkg/utilities/nttools/doc/gtedit.hlp @@ -0,0 +1,116 @@ +.help gtedit Aug93 tables +.ih +NAME +gtedit -- Graphically edit an STSDAS table. +.ih +USAGE +gtedit input xcolumn ycolumn +.ih +DESCRIPTION +The 'gtedit' task lets you graphically edit +an STSDAS table. +You can use the editor to delete rows. You can +also choose whether to overwrite the existing +file (by setting 'inplace=yes') or you +can create a new output table. You can also +save deleted points in a separate file by +setting the 'reject' parameter to an output +file name. + +The rows that are plotted can be selected using the :x and :y +commands to specify columns for the X and Y axes. Points that +are to be deleted will be marked with an "x" (this information +is retained if columns change). + +To mark a point for deletion you can: +.nf +1) Specify the points individually +2) Define a box in which all points will be deleted +3) Delete all points on one side of the cursor or line segment +.fi + +You can also toggle between "delete mode" and "undelete mode". When +you are in undelete mode, any previously-deleted points that you +selected will be unmarked. + +If you don't like using 'gtedit', you can switch to the 'tedit' +task and edit the table in the usual manner. +.ih +CURSOR COMMANDS + +.nf + GTEDIT Interactive Cursor Commands + +? Print options +: Colon commands +a print out the complete row for the data point nearest the cursor +b delete all points with Y values less than the cursor Y position +c mark the corner of a box +d delete the point nearest the cursor +e exit and save changes in the output table +f make all the marked deletions and replot remaining data +h print out the column names of the input table +l delete all points with X values less than the cursor X position +p replot the graph possibly using new data columns +q quit and do not save changes made since the last 'f' +r delete all points with X values greater than the cursor X position +s mark one end of a line segment +t delete all points with Y values greater than the cursor Y position +u toggle between delete and undelete mode +v change from gtedit to tedit mode +z display current status (delete or undelete) + +:x(-) xcolumn set the table column for the X axis and possibly replot +:y(-) ycolumn set the table column for the Y axis and possibly replot +- do not automatically replot after reading in new column + +.fi +.ih +PARAMETERS +.ls input [file name] +The input table to be edited. +.le +.ls xcolumn +The name of the column in the input table to use for the X-axis of the plot. +.le +.ls ycolumn +The name of the column in the input table to use for the Y-axis of the plot. +.le +.ls (device = "stdgraph") +The standard graphics device. +.le +.ls (commands = "") +The graphics cursor. +.le +.ls (inplace = no) +Edit the table inplace. No new output table is created and the original +table is overwritten. +.le +.ls (output = "") +The name of the output table if the input table is not edited inplace. If +inplace = no then output should be a valid filename. +.le +.ls (reject = "") +If this parameter contains a valid filename then this table will contain +the points which were deleted using this task. +.le +.ls (gtpar = "") [pset] +The name of the pset containing the parameters which describe the plot +attributes. +.ih +EXAMPLES +1. Edit a table containing the output photometry from DAOPHOT. +Initially plot the magnitude (MAG) versus the error in the magnitude (MAGERR) +to decide which points to delete. + +.nf + st> gtedit m31.mag MAG MERR +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Dennis Crabtree. +.ih +SEE ALSO +.endhelp diff --git a/pkg/utilities/nttools/doc/gtpar.hlp b/pkg/utilities/nttools/doc/gtpar.hlp new file mode 100644 index 00000000..7a06d627 --- /dev/null +++ b/pkg/utilities/nttools/doc/gtpar.hlp @@ -0,0 +1,117 @@ +.help gtpar May92 tables +.ih +NAME +pltpar -- Parameters describing plot attributes. +.ih +USAGE +pltpar +.ih +DESCRIPTION +Parameters in the 'gtpar' pset specify the attributes of plots drawn with the +'gtedit' task. + +Note that this is a pset, not an executable task. Invoking the pset by name +runs 'eparam', enabling the parameters to be interactively edited. +Parameters can also be modified on the +CL command line by specifying the pset name and parameter name, +for example, "gtpar.box = no"). +The pset name will also appear as one of +the task parameters in the 'gtedit' task; +to change values in the pset, +position the cursor to the 'gtpar' pset name and type ":e" to invoke 'eparam'. +.ih +PARAMETERS +.ls (wx1 = 0) [real] +Left world X-coordinate (if autoscaling is not used). +.le +.ls (wx2 = 0.) [real] +Right world X-coordinate (if autoscaling is not used). +.le +.ls (wy1 = 0.) [real] +Lower world Y-coordinate (if no autoscaling is used). +.le +.ls (wy2 = 0.) [real] +Upper world Y-coord (if not autoscaling). +.le +.ls (marker = box) [string, allowed values: point | box | plus | +cross | circle | diamond | hline | vline | hebar | vebar] + +The name of the style of marker plotted at each point if 'pointmode=yes'. +.le +.ls (szmarker = 0.005) [real] +The size of the markers if 'pointmode = yes'. If this parameter is greater +than 0, its value represents the marker size in world coordinates (WC). If it +is less than zero, the absolute value will be used, representing size in +normalized device coordinates (NDC). If it is set to exactly zero, and the +input is from a list file, +then the third column in the input data is used as the marker size. +.le +.ls (logx = no) [boolean] +Scale the X axis logarithmically? +.le +.ls (logy = no) [boolean] +Scale the Y axis logarithmically? +.le +.ls (box = yes) [boolean] +Draw the box containing the axes and labels around periphery of the +window? +.le +.ls (ticklabels = yes) [boolean] +Label major tick marks? +.le +.ls (grid = no) [boolean] +Draw grid lines on plot? +.le +.ls (xlabel) [string] +X-axis label. +.le +.ls (ylabel) [string] +Y-axis label. +.le +.ls (title = imtitle) +The plot title consists of a standard system-supplied string containing +the user's name, date, etc. If the 'title' parameter contains the string +"imtitle" (the default), then the plot title will contain a second line +made up from the input file or table name. Otherwise, the title will +contain the string value. +.le +.ls (vx1 = 0.) [real, min = 0, max = 1] +Left limit of device viewport. +.le +.ls (vx2 = 0.) [real, min = 0, max = 1] +Right limit of device viewport. +.le +.ls (vy1 = 0.) [real, min = 0, max = 1] +Bottom limit of device viewport. +.le +.ls (vy2 = 0.) [real], min = 0, max = 1] +Upper limit of device viewport. +.le +.ls (majrx = 5) [integer] +Number of major divisions along the X grid. +.le +.ls (minrx = 5) [integer] +Number of minor divisions along the X grid. +.le +.ls (majry = 5) [integer] +Number of major divisions along the Y grid. +.le +.ls (minry = 5) [integer] +Number of minor divisions along the Y grid. +.le +.ls (round = no) [boolean] +Round axes to nice values? +.le +.ls (fill = yes) [boolean] +Fill the viewport rather than enforcing unity aspect ratio? +.ih +EXAMPLES +.ih +BUGS +.ih +SEE ALSO +sgraph + +Type "help tables opt=sys" for a higher-level description of the 'tables' +package. +.endhelp diff --git a/pkg/utilities/nttools/doc/imtab.hlp b/pkg/utilities/nttools/doc/imtab.hlp new file mode 100644 index 00000000..a2438f8a --- /dev/null +++ b/pkg/utilities/nttools/doc/imtab.hlp @@ -0,0 +1,169 @@ +.help imtab Mar2000 tables +.nj +.ih +NAME +imtab -- Create a table from an image. +.ih +USAGE +imtab input outtable colname +.ih +DESCRIPTION +This task copies data from an image to a table. +Pixel values are read from the image line by line +and written to a column in increasing row number. +The image may be of any dimension, +but a single column is written. +If the table already exists then columns will be added to it; +names of new columns must not conflict with existing names. +If the table does not exist it will be created. + +The number of names in the 'input' list must be the same as +the number of names in the 'outtable' list, +unless 'outtable' is "STDOUT". + +Information about the image dimension and axis lengths will not be kept +in keywords, but there is an option to write the image pixel numbers +to columns of the table. +The pixel coordinates may be just the pixel numbers, +or they may be world coordinates at the pixel locations. + +A history record will be added to the table giving +the name of the data column and the name of the image. +If pixel coordinates are written to the table, +another history record is written that also gives +the column name for the image data +and gives the column names for the pixel coordinates. +.ih +PARAMETERS +.ls input = "" [file name template] +The names of the images to be written to the tables. +.le +.ls outtable = "" [file name template] +The names of the output tables. +If outtable = "STDOUT" or if the output has been redirected, +the values will be written to the standard output. + +If the output table is of type text (e.g. STDOUT), +the data values will be in the first column. +If the pixel coordinates are also printed, +they will be in the following columns. +.le +.ls colname = "" [string] +A column of this name will be created in the output table, +and the values of the image will be written to this column. +The same column name will be used for all output tables. +.le +.ls (pname = "") [string] +If 'pname' is not null, +the pixel coordinates will also be written to columns of the table. +The names of these columns will be the value of 'pname' with the +numbers 1, 2, 3, etc appended, +corresponding to the sample number, line number, band number, etc. +This may be especially useful for a multi-dimensional input image, +since all the data values are written to one column. +The same column names will be used for all output tables. +See also 'wcs' and 'formats'. + +If 'pname' is null (or blank) the pixel numbers will not be written. +.le +.ls (wcs = "logical") [string, allowed values: logical | physical | world] +This parameter is only gotten if 'pname' is not null. +In this case, the user has the option of which coordinate system +should be used when writing pixel coordinates to the table. +The "logical" coordinates are simply the pixel numbers +of the image or image section. +The "physical" coordinates are also pixel numbers, +but they can differ from logical coordinates +if an image section has been taken. +Physical coordinates have the same origin and sampling as the original image. +The "world" coordinates are coordinates such as wavelength, time, +or right ascension and declination. +The translation from logical to world coordinates is given by +header keywords CRVAL1, CRPIX1, CD1_1, CTYPE1, etc. + +The number of pixel coordinates written by 'imtab' differs from +the number written by 'listpixels' when wcs = "physical" or "world" +and an image section was used that reduces the dimension of the image. +'imtab' gives one pixel coordinate column for each dimension +of the original image, while 'listpixels' gives one pixel coordinate +for each dimension of the image section. + +Type "help mwcs$MWCS.hlp fi+" for extensive information on coordinate systems. +.le +.ls (formats) [string] +The print formats to use for the pixel coordinates, one format +per axis, with the individual formats separated by whitespace. +This parameter is only gotten if 'pname' is not null. +If the formats are not given, a default format is assigned. +See the help for 'listpixels' for extensive information on formats. +These formats are saved in the descriptors for the table columns, +so these formats will be used if the table is printed. +If the output table is text rather than binary, +these formats will be used to write the coordinates to the text table. +.le +.ls (tbltype = "default") [string, allowed values: default | row | +column | text ] + +If the output table does not already exist, +you can specify whether the table should be created in row or column +ordered format. +As an alternative to a binary table, +tbltype = "text" means the output will be a plain text file. +.le +.ih +EXAMPLES +1. Copy image "hr465_flux.imh" to table "hr465.tab", column "flux": + +.nf + tt> imtab hr465_flux.imh hr465.tab flux +.fi + +2. Copy the 2-D image "ir27.hhh" to column "ir27" of table "map.tab", +saving the pixel numbers in columns "pix1" and "pix2": + +.nf + tt> imtab ir27.hhh map.tab ir27 pname="pix" +.fi + +3. Copy the 1-D section [257:257,129:384] of +x0y70206t.d0h to column "x0y70206" of table "focus.tab". +Also write the right ascension and declination +("world" coordinates) to columns "p1" and "p2" respectively +using HH:MM:SS.d and DD:MM:SS.d formats. +We use "%12.1H" for right ascension and "%12.1h" for declination. +The capital "H" in the format means that the values will be divided by 15 +to convert from degrees to hours before formatting in sexagesimal. +Note that we get two columns of pixel coordinates even though +the image section is only 1-D. +Physical or world coordinates will be 2-D in this case +because the original image "x0y70206t.d0h" is 2-D. + +.nf + tt> imtab x0y70206t.d0h[257:257,129:384] focus.tab x0y70206 \ + >>> pname="p" wcs="world" formats="%12.1H %12.1h" +.fi + +4. Use the same image as in the previous example, +but print the values on the standard output. + +.nf + tt> imtab x0y70206t.d0h[257:257,129:384] STDOUT x0y70206 \ + >>> pname="p" wcs="world" formats="%12.1H %12.1h" +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +The 'tabim' task copies a column of a table to an image. +The 'listpixels' task in the 'images' package writes data values and +pixel coordinates to the standard output. +The parameters 'wcs' and 'formats' are the same in 'imtab' and 'listpixels'. +For detailed information on the distinction between logical, physical and +world coordinates, type "help mwcs$MWCS.hlp fi+". + +Type "help tables option=sys" for a higher-level description of +the tables package. +.endhelp diff --git a/pkg/utilities/nttools/doc/keypar.hlp b/pkg/utilities/nttools/doc/keypar.hlp new file mode 100644 index 00000000..b1f395f6 --- /dev/null +++ b/pkg/utilities/nttools/doc/keypar.hlp @@ -0,0 +1,83 @@ +.help keypar Dec94 tables +.ih +NAME +keypar -- Copy a header keyword to an IRAF parameter. +.ih +USAGE +keypar input keyword +.ih +DESCRIPTION +This task reads a header keyword from an image or table file. The +keyword is written to the IRAF parameter 'value' as a character +string. If the header keyword is boolean, the value of 'value' will +either be "yes" or "no". If the header keyword is not found, 'value' +will be set to a null string. String parameters, such as 'value', can +be converted to numeric data types with the built in functions real() +and int(). +.ih +PARAMETERS +.ls input [file name] +Name of the file containing the header keyword. +.le +.ls keyword [string] +Name of the header keyword to be retrieved. (The keyword +name is not case sensitive.) +.le +.ls (silent = no) [bool] +If this parameter is set to no (the default) a warning message will be +printed if the keyword is not found in the header. If it is set to +yes, the warning message is suppressed. +.le +.ls (value) [string] +An output parameter that will contain the value passed from the header +keyword. +.le +.ls (found) [bool] +An output parameter that will be set to yes if the keyword is found in +the header and no if it is not. +.le +.ih +EXAMPLES +1. Print the number of groups (i.e., the 'GCOUNT' keyword) +in the image file 'image.hhh': + +.nf +tt> keypar image.hhh gcount +tt> print(keypar.value) +.fi + +2. Print the range of the data in the second group of the same image by +reading the values of the 'DATAMIN' and 'DATAMAX' keywords: + +.nf +tt> keypar image.hhh[2] datamin +tt> x = real(keypar.value) +tt> keypar image.hhh[2] datamax +tt> y = real(keypar.value) +tt> print(y-x) +.fi + +3. Print the component name (i.e., the 'COMPNAME' header keyword) +for the table 'thruput.tab': + +.nf +tt> keypar thruput.tab compname +tt> print(keypar.value) +.fi + +4. Check for the existence of the exposure time in an image header: + +.nf +tt> keypar image.hhh exptime silent+ +tt> if (keypar.found) { +>>> print keypar.value +>>> } else { +>>> print INDEF +>>> } +.fi +.ih +REFERENCES +This task was written by Bernie Simon. +SEE ALSO +keytab, parkey, partab, tabkey, tabpar +.endhelp diff --git a/pkg/utilities/nttools/doc/keyselect.hlp b/pkg/utilities/nttools/doc/keyselect.hlp new file mode 100644 index 00000000..57e96137 --- /dev/null +++ b/pkg/utilities/nttools/doc/keyselect.hlp @@ -0,0 +1,246 @@ +.help keyselect Mar92 tables +.ih +NAME +keyselect -- Copy selected image header keywords to an STSDAS table. +.ih +USAGE +keyselect input output cols +.ih +DESCRIPTION +This task copies the specified image header keywords to an STSDAS +table. The required parameters are the input list of image names, the +output STSDAS table name, and the list of header keywords. All groups of +each image will be examined if the list of header keywords contains a +group parameter. Otherwise only the first group of each image will be +examined. The task appends rows to the output table if it exists or +creates a new table if the output table does not exist. If the output +table exists, column names must match the names in the existing table. +The column names in the output table are the same as the header keywords +unless they are explicitly specified, as described below. + +If a keyword is missing from an image header a warning message is +printed and a null value inserted into the table. The default type of +the table column is determined from the type of the header keyword. +Text columns have a default length of 19 characters, unless the table +column is the concatenation of several keywords, in which case the +default length will be 63 characters. A column description file must +be used if you want to override the default type or length of a table +column. + +The third parameter ('cols') is a list of items specifying the header keyword +names and table column names. Items in the list are separated by +commas or whitespace. Three different kinds of items may appear in the +list: a keyword name, a table column name followed by a equals sign +followed by a keyword name, or a table column name followed by an +equals sign followed by a list of keyword names separated by colons. +If the item in the list is a keyword name, the table column name is +the same as the keyword name. To specify a table column name different +than the keyword name, the item in the list should be the table column +name followed by an equals sign followed by the keyword name. To +concatenate several header keywords into a string separated by commas, +a list of keyword names separated by colons should replace the header +keyword name in the item. The following list gives examples of the +three types of items. + +.nf +FGWA_ID +GRATING=FGWA_ID +OBS_MODE=DETECTOR:FGWA_ID:APER_ID +.fi + +In the first case, both the header keyword name and table column name +are 'fgwa_id'. In the second case the table column name is 'grating'. +In the third case table column name is 'obs_mode' and the values in +the column are the concatenation of the header keywords 'detector', +'fgwa_id', and 'aper_id' separated by commas. + +Special keywords may also be used in the list wherever a header +keyword may be used. Special keywords are used to place the image name +or parts of the image name in the output table. The name of a special +keyword always starts with a "$". The different special keywords, +their types, and default table column names are given in the following +list. + +.nf +$group int group +$dir text directory +$ext text extension +$hdr text header_file +$pix text data_file +$root text rootname +.fi + +If an image has the name 'yref$y00vk101a.r1h[1]', the group will be 1, +the directory 'yref$', the extension 'r1h', the header file +'y00vk101a.r1h', the data file 'y00vk101a.r1d', and the root name +'y00vk101a'. + +The hidden task parameter 'expr' is used to select which images are +examined when writing header keywords to the output table. If this +task parameter is set to its default value, ' ' (a blank string), all +images named in the image template will be examined. Otherwise the +task parameter is interpreted as a boolean (logical) expression. The +variables in the expression are header keyword names. As each image is +opened the values of the header keywords are substituted for the +keyword name. If the expression is true, the header keywords specified +in the 'cols' parameter are copied into the output table. The special +keywords mentioned above may also be used in the expression. If a +keyword name contains dashes the keyword name should be preceded by a +'@' and enclosed in quotes. For example, 'date-obs' should be given as +'@"date-obs"' in the expression. + +The following boolean operators may be used in the expression: + +.nf +equal == not equal != +less than < less than or equal <= +greater than > greater than or equal >= +or || and && +negation ! +.fi + +The expression may also include the usual arithmetic operators and +functions. Arguments to the trigonometric functions must be in +degrees. The available operators are: + +.nf +addition + subtraction - +multiplication * division / +negation - exponentiation ** +string concatenation // +.fi + +The following is a list of the available functions: + +.nf +absolute value abs(x) cosine cos(x) +sine sin(x) tangent tan(x) +arc cosine acos(x) arc sine asin(x) +arc tangent atan(x) arc tangent atan2(x,y) +exponential exp(x) square root sqrt(x) +natural log log(x) common log log10(x) +minimum min(x,y) maximum max(x,y) +modulo mod(x,y) keyword found find(x,y,z,..) +.fi + +One new function, find, is available in addition to the usual arithmetic +functions. The argument of this function is a list of header keyword +names. The function returns true if all the header keywords are found +in the image and false if one or more header keywords in the list are +not found. The arguments to this function should be placed in quotes +as otherwise the value of the header keyword will checked instead of +the name. That is, if 'find(detector)' is used instead of +'find("detector")', the task will look for a header keyword whose name +is the value of the detector keyword. + +The 'cols' and 'expr' parameters can also be the name of a file +preceded by an '@' character. If this is done, the task will read the +list of keyword names or boolean expression from the specified file. +Newlines in the file are treated as if they were blanks, so lines may +be broken wherever a blank would be correct. Comments (lines starting +with a '#' character) are not permitted in either file. + +The hidden parameter 'cdfile' is the name of the column description +file. The default value for this parameter is ' ' (a blank string). If +the parameter contains a blank string no column description file is +used and the column data type is taken from the type of the header +keyword. A column description file contains one line for each column +in the table. Each line contains four fields in the following order: +the column name, the data type, the print format, and the units. Any +of the fields except the column name may be omitted. If a field is +omitted the default for that field will be used instead. Fields are +not case sensitive except for the units field. The column name in the +column description file must match the column name in the 'cols' +parameter. If a column name in the 'cols' parameter is not found in +the column description file, a warning message is printed and the +defaults are used for that table column. Column names in the column +description file that are not in the 'cols' parameter are ignored. For +further information on the format of a column description file, refer +to the help file for 'tlcol'. + +.ih +PARAMETERS +.ls input [file name template] +List of image names. The usual wild card characters can be used. If +the list of keyword names or the expression contains a group parameter +all groups of each image will be examined unless a group is explicitly +specified as part of the image name. +.le +.ls output [file name] +The name of the output STSDAS table. If the table already exists new +rows will be added to the existing table. Column names must match +names in the existing table. If the table does not exist a new table +will be created and any column names may be used. +.le +.ls cols [string] +The list of header keyword names separated by white space or commas. +Table column names are the same as the keyword names unless explicitly +specified in the form =. Several keywords can be +concatenated by using the form =:. If the +first character in the parameter is an '@', the rest of the parameter +is interpreted as a file name containing the list of keyword names. +.le +.ls (expr = " ") [string] +A boolean expression used to select which images are examined for +header keywords. If the string is blank (the default) all images named +in the input list are examined. Variables in the expression are +header keyword names. An image is selected if substituting the value +of the header keywords for their names makes the expression true. The +syntax of the expression follows the usual CL and SPP conventions. If +the first character in the expression is a '@', the rest of the +expression is interpreted as a filename containing the expression. +.le +.ls (cdfile = " ") [file name] +The name of the column description file. The format of a column +description file is defined in the help for 'tlcol'. Column names used +in the column description file must match the names in the 'cols' +parameter (except for case). +.le +.ih +EXAMPLES +1. Create an STSDAS table from the headers of the dead diode reference +images: + +.nf +tt> keyselect yref$*.r4h ddt.tab detector,headname,dataname +.fi + +2. Create the same table, only name the columns "header_file" and +"data_file": + +.nf +tt> keyselect yref$*.r4h ddt.tab \ +>>> detector,header_file=headname,data_file=dataname +.fi + +3. Only select images with the blue detector: + +.nf +tt> keyselect yref$*.r4h ddt.tab detector,headname,dataname \ +>>> expr="detector='blue'" +.fi + +4. Use a column description file when creating the table: + +.nf +tt> keyselect yref$*.r4h ddt.tab \ +>>> detector,header_file=headname,data_file=dataname cdfile="ddt.cd" +.fi + +The contents of the column description file: + +.nf +DETECTOR CH*5 +HEADER_FILE CH*18 +DATA_FILE CH*18 +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO + +Type "help tables opt=sys" for a description of the 'tables' package. +.endhelp diff --git a/pkg/utilities/nttools/doc/keytab.hlp b/pkg/utilities/nttools/doc/keytab.hlp new file mode 100644 index 00000000..1bccecf5 --- /dev/null +++ b/pkg/utilities/nttools/doc/keytab.hlp @@ -0,0 +1,61 @@ +.help keytab Dec94 tables +.ih +NAME +keytab -- Copy a header keyword to a table element. +.ih +USAGE +keytab input keyword table column row +.ih +DESCRIPTION +This task reads a header keyword from either an image or a table file +and writes it to a table element (row and column position). If the +data type of the header keyword differs from that of the table +element, then the value is converted to the appropriate data type. If +the keyword is not found in the header, the element will be set to the +null value appropriate for the column type. +.ih +PARAMETERS +.ls input [file name] +Name of the file containing header keyword. +.le +.ls keyword [string] +Name of the header keyword to be read. (Keyword names are not case sensitive.) +.le +.ls table [file name] +Name of the table to which the value will be written. +.le +.ls column [string] +Name of table column. (Column names are not case sensitive.) +.le +.ls row [integer, min=1, max=INDEF] +Table row number. +.le +.ls (silent = no) [bool] +If this parameter is set to no (the default) a warning message will be +printed if the keyword is not found in the header. If it is set +to yes, the warning message is suppressed. +.le +.ih +EXAMPLES +1. Copy the component name (i.e., the 'COMPNAME' header keyword) +from the table 'thruput.tab' to the +first row of the table 'graph.tab'. + +.nf +tt> keytab thruput.tab COMPNAME graph.tab COMPNAME 1 +.fi + +2. Copy the zero point of the second group (i.e., the 'CRVAL1' keyword) +in the image file 'image.hhh' to the first +wavelength in the table 'spectrum.tab'. + +.nf +tt> keytab image.hhh[2] CRVAL1 spectrum.tab WAVELENGTH 1 +.fi +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +keypar, parkey, partab, tabkey, tabpar +.endhelp diff --git a/pkg/utilities/nttools/doc/parkey.hlp b/pkg/utilities/nttools/doc/parkey.hlp new file mode 100644 index 00000000..8cf317ee --- /dev/null +++ b/pkg/utilities/nttools/doc/parkey.hlp @@ -0,0 +1,73 @@ +.help parkey Dec90 tables +.ih +NAME +parkey -- Write an IRAF parameter to a header keyword. +.ih +USAGE +parkey value output keyword +.ih +DESCRIPTION +This task changes the value of a header keyword in either a table or an +image. If the value of the task parameter 'add' is "yes", the task will +allow you to add a new keyword to the header, otherwise, adding a new +keyword will cause an error. Type conversion is performed if the data type of +the header keyword differs from the data type of the input parameter 'value'. +If a new +keyword is added to the file, the type is determined +from the input value. The +strings "yes", "y", "no", "n", "true", "t", "false", and "f", in either +upper or lower case, are interpreted as boolean values. +.ih +PARAMETERS +.ls value [string] +Input value to be written to the header keyword. (Strings are case sensitive.) +.le +.ls output [file name] +Name of the file whose header keyword is to be changed. +.le +.ls keyword [string] +Name of the header keyword to be changed. (The name is not case sensitive.) +.le +.ls (add = no) [boolean] +Allow new header keywords to be added? + +If 'add = no', then existing keywords +can take new values but no new keywords can be added to the file. +.le +.ih +EXAMPLES +1. Set the header keyword 'OVERSCAN' in the file 'image.hhh' to 5: + +.nf +tt> parkey 5 image.hhh overscan +.fi + +2. Set the group parameter 'CTYPE1' in the second group of the same +file to "ANGSTROM": + +.nf +tt> parkey ANGSTROM image.hhh[2] ctype1 +.fi + +3. Set the header keyword 'YSTEP' to the value stored +in the IRAF parameter 'x': + +.nf +tt> parkey (x) image.hhh ystep +.fi + +4. Add the keyword 'COMPNAME' to the table header and put the value "FILTER1" +in it: + +.nf +tt> parkey FILTER1 graph.tab compname add+ +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +keypar, keytab, partab, tabkey, tabpar +.endhelp diff --git a/pkg/utilities/nttools/doc/partab.hlp b/pkg/utilities/nttools/doc/partab.hlp new file mode 100644 index 00000000..fb0b9239 --- /dev/null +++ b/pkg/utilities/nttools/doc/partab.hlp @@ -0,0 +1,62 @@ +.help partab Nov91 tables +.ih +NAME +partab -- Copy an IRAF parameter to a table element. +.ih +USAGE +partab value table column row +.ih +DESCRIPTION +This task changes the value of a table element to the value of the input +parameter 'value'. If 'value' is set to "INDEF", the table element will be +set to undefined. If the data type of the table element is different from +that of the input parameter 'value', this task will perform +type conversion. The strings +"yes", "y", "no", "n", "true", "t", "false", and "f", in either upper or +lower case are interpreted as boolean values. +.ih +PARAMETERS +.ls value [string] +The IRAF parameter that will be copied into the table element. +.le +.ls table [file name] +Name of the table. +.le +.ls column [string] +Column name. (Column names are not case sensitive). +.le +.ls row [integer, min=1, max=INDEF] +Row number. +.le +.ih +EXAMPLES +1. Set the twelfth component (i.e., row 12 of column 'COMPNAME') +in the file 'graph.tab' to "FILTER1": + +.nf +tt> partab FILTER1 graph.tab COMPNAME 12 +.fi + +2. Set the first wavelength (i.e., row 1 of column 'WAVELENGTH') in +the file 'spectrum.tab' to the value contained in parameter +'x': + +.nf +tt> partab (x) spectrum.tab WAVELENGTH 1 +.fi + +3. Set the hundreth wavelength (i.e., row 100 of column 'WAVELENGTH') +in 'spectrum.tab' to undefined: + +.nf +tt> partab INDEF spectrum.tab WAVELENGTH 100 +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +keypar, keytab, parkey, tabkey, tabpar +.endhelp diff --git a/pkg/utilities/nttools/doc/pltpar.hlp b/pkg/utilities/nttools/doc/pltpar.hlp new file mode 100644 index 00000000..d43ecde7 --- /dev/null +++ b/pkg/utilities/nttools/doc/pltpar.hlp @@ -0,0 +1,160 @@ +.help pltpar Jul93 tables +.ih +NAME +pltpar -- Edit the parameter set that describes plot attributes. +.ih +USAGE +pltpar +.ih +DESCRIPTION +The 'pltpar' parameters specify the attributes of plots drawn by the +'sgraph' task. + +Note that this is a pset, not an executable task; it defines a set of +parameters used by other tasks. Invoking the pset by name runs +'eparam' on the parameter set, allowing the user to modify the +parameters. Alternatively, the parameters may be modified on the +command line by specifying the pset name and parameter name, for +example, you can type "pltpar.pointmode=yes" to set only the +'pointmode' parameter. Parameters can also be edited by using +'eparam' on the calling task (e.g., by typing "eparam sgraph"), in +which case, 'pltpar' will appear as one of the task parameters; the +'pltpar' parameters may then be edited by positioning the cursor on +the line containing the pset name and typing ":e". After editing +the pset parameters, press Control-Z to return to the main task parameter menu. +.ih +PARAMETERS +.ls (stack = no) [boolean] +Stack multiple curves on separate vertical axes? + +If this is set to +"no", all curves will be scaled together and plotted on a single set of +axes. Otherwise a separate set of axes will be drawn, joined into a +single vertical column. +.le +.ls (axis = 1) [integer, min = 1, max = 7] +Axis along which projection is to be taken. If the input image has +more than one dimension, the data will be projected to a single +dimension. This parameter specifies the axis along which projection +will occur. The default is one, i.e., project along the X axis. +.le +.ls (pointmode = no) [boolean] +Plot points only? + +If set to "no", the task will plot connected curves. Note that to +plot error bars, you must set 'pointmode = no' and 'erraxis = 1' or 'erraxis = +2'. See the descriptions of 'marker' and 'szmarker'. +.le +.ls (marker = box) [string, allowed values: point | box | plus | +cross | circle | diamond | hline | vline | hebar | vebar] + +The marker style for each plotted point if 'pointmode=yes'. See also +'szmarker'. +.le +.ls (szmarker = 0.005) [real] +The size of the markers if 'pointmode = yes'. If 'szmarker > 0', use +this value as the size in normalized device coordinates (NDC) . If +'szmarker < 0', use the absolute value as the size in world coordinates +(WCS). If 'szmarker = 0' and the input comes from a text file, use the +third column in the input data as the marker size. If data are from an +image or a table, then 'szmarker' specifies the same size of every point. +.le +.ls (erraxis = 0) [integer, min = 0, max = 2] +Plot the data as error bars? If 'erraxis = 0', plot the data as values +rather than error bars; if 'erraxis = 1', plot the data as errors +parallel to the X axis; if 'erraxis =2', plot the data as errors +parallel to the Y axis. Note that the value of 'erraxis' is ignored if +'pointmode = yes' and error bars will not be drawn. +.le +.ls (errtype = bartck) [string, allowed values: tckbar | bar | tick | +limit] + +The style of error bars (if 'erraxis' is not zero). +.le +.ls (pattern = solid) [string, allowed values: solid | dashed | +dotted | dotdash] + +The line pattern style for the curve or the first of multiple curves. +.le +.ls (crvstyle = straight) [string, allowed values: straight | pseudohist +| fullhist] + +The curve style. 'straight' means line segments will connect data +points, 'pseudohist' means that horizontal segments will be placed at +each value and vertical segments will connect these, 'fullhist' means a +bar graph, or horizontal segments at each value with vertical lines +connecting the value with the bottom axis. +.le +.ls (rejectlog = yes) [boolean] +Replace invalid logarithmic values with 'INDEF'? + +Invalid values will +be ignored in scaling and plotting. +.le +.ls (box = yes) [boolean] +Draw the box containing the axes and labels around the edge of the +window? +.le +.ls (sysid = yes) [boolean] +Include standard system information in the plot title? + +If the 'sysid' +parameter is "yes", then a string including the user's name, date, host +name, etc. is included in the plot title. +.le +.sp +.ls (barpat ="hollow") [string, allowed values: hollow, solid, ahatch, +bhatch, chatch, dhatch] + +Fill pattern for bar plot. The nature of the pattern depends on the +device and graphics kernel (driver) used to plot. Many kernels do not +support fill patterns. +.le +.sp +.ls (crvcolor = INDEF) [integer, min = 1] +Color index of data curve(s). This color applies only to plotted data +curves. The color of any axes, labels, etc., is specified by +the `color' parameter. Note that the actual, drawn color will depend +on the device and graphics kernel (driver) used to plot. Many kernels +do not support color at all. The usual interpretation of the color +index is: +.nf + + 1 -- Black + 2 -- White + 3 -- Red + 4 -- Green + 5 -- Blue + 6 -- Yellow + 7 -- Cyan (blue/green) + 8 -- Magenta (red/blue) +.fi +.le +.ls (color = INDEF) [integer, min = 1] +Color index of axis and labels. The color of the data curve(s) is +specified by the `crvcolor' parameter. Note that the actual, drawn +color will depend on the device and graphics kernel (driver) used to +plot. Most kernels do not support color. +.le +.ls (cycolor = no) [boolean] +Cycle colors instead of line style for multiple curves? + +If multiple curves are plotted on the same viewport (axes), i.e., +'stack=no', then use the color specified by the 'crvcolor' parameter +for the first curve, and the next available color for each subsequent +curve. There are eight available colors, as described in the +description of the 'crvcolor' parameter. +.le +.sp +.ls (version = 17August92) [string] +Date that the task was installed. This parameter should not be changed by +the user. +.le +.ih +EXAMPLES +.ih +BUGS +.ih +SEE ALSO +sgraph +.endhelp diff --git a/pkg/utilities/nttools/doc/tabim.hlp b/pkg/utilities/nttools/doc/tabim.hlp new file mode 100644 index 00000000..2fdba5fb --- /dev/null +++ b/pkg/utilities/nttools/doc/tabim.hlp @@ -0,0 +1,98 @@ +.help tabim Mar2000 tables +.nj +.ih +NAME +tabim -- Copy a table column to an image. +.ih +USAGE +tabim intable output colname ndim n1 n2 n3 n4 n5 n6 +.ih +DESCRIPTION +This task writes values from a column of a table to an image. +If the image does not exist, it will be created. +The value in the first row is assigned to the first pixel of the image, +and the value in the last row is assigned to the last pixel of the image. +Columns containing pixel numbers (optionally written by 'imtab') are ignored, +but you can specify the axis lengths of a multi-dimensional output image. +The number of rows in the table must equal the number of pixels in the image. +.ih +PARAMETERS +.ls intable = "" [file name template] +The names of the input tables. +.le +.ls output = "" [file name template] +The names of the output images. +If an output image does not exist it will be created. +If the image does exist it will be overwritten with values from the table. +A section of an existing image may be specified, +but note that the size must equal the number of rows in the table. +.le +.ls colname = "" [string] +The name of the column in 'intable' that is to be written to the image. +The same column name is used for all input tables. +.le +.ls ndim = 0 [integer, min=0, max=7] +If the output image does not exist, +'ndim' can be used to specify +the dimension of the image to be created. +ndim = 0 or 1 results in a one-dimensional image +which has as many elements as rows in the table. +If 'ndim' is greater than one +and the output image does not already exist, +then the parameters 'n1', 'n2', etc will be taken +to specify the axis lengths of the output image. +The lengths of all but the last axis will be gotten from 'n1', 'n2', etc.; +the last axis length will be computed from +the number of rows in the table +and the lengths of the other axes. +It is an error if the product of the specified axis lengths +does not divide evenly into the number of rows in the table. +.le +.ls n1 = 1 [integer, min=1, max=INDEF] +Length of first axis. +'n1', 'n2', etc., are ignored if ndim = 0 or 1. +.le +.ls n2 = 1 [integer, min=1, max=INDEF] +Length of second axis. +This and the subsequent axis length parameters will be ignored if ndim < 3. +.le +.ls n3 = 1 [integer, min=1, max=INDEF] +Length of third axis. +.le +.ls n4 = 1 [integer, min=1, max=INDEF] +Length of fourth axis. +.le +.ls n5 = 1 [integer, min=1, max=INDEF] +Length of fifth axis. +.le +.ls n6 = 1 [integer, min=1, max=INDEF] +Length of sixth axis. +.le +.ih +EXAMPLES +1. Copy column "flux" from table "hr465.tab" to +the 1-D image "hr465_flux.imh": + +.nf + ta> tabim hr465.tab hr465_flux.imh flux 1 +.fi + +2. Create a three-dimensional image "ir27.imh" of size 62 x 64 x 4. +Read the values from column "v1" of table "t18_30.tab", +which has 62*64*4 rows. + +.nf + ta> tabim t18_30.tab ir27.imh v1 3 62 64 +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +The 'imtab' task copies an image to a column of a table. + +Type "help tables option=sys" for a higher-level description of +the tables package. +.endhelp diff --git a/pkg/utilities/nttools/doc/tabkey.hlp b/pkg/utilities/nttools/doc/tabkey.hlp new file mode 100644 index 00000000..0f87c64f --- /dev/null +++ b/pkg/utilities/nttools/doc/tabkey.hlp @@ -0,0 +1,68 @@ +.help tabkey Nov91 tables +.ih +NAME +tabkey -- Copy a table element to a header keyword. +.ih +USAGE +tabkey table column row output keyword +.ih +DESCRIPTION +This task copies the value of a table element to a header +keyword in either a table +or an image. If the table element and the header keyword are of different +data types, this task will convert the type. +An error will occur if any attempt is made +to copy an undefined table element to a header keyword. If the value of +the task parameter 'add' is "yes", the task will allow you to add a new +keyword to the header, otherwise, adding a new keyword will cause an +error. +.ih +PARAMETERS +.ls table [file name] +Name of table containing the element to be copied. The particular element +is defined by the 'column' and 'row' parameters. +.le +.ls column [string] +Name of column. (Column names are not case sensitive.) +.le +.ls row [integer, min=1, max=INDEF] +Row number. +.le +.ls output [file name] +Name of the file with the header keyword whose value is to be changed. +.le +.ls keyword [string] +Name of header keyword. (Header keyword names are not case sensitive.) +.le +.ls (add = no) [boolean] +Allow new keywords to be added to the header? +If 'add = no', then only existing header keywords can be modified--an error +will occur if a keyword is specified that does not already exist. +.le +.ih +EXAMPLES +1. Copy the first component name (i.e., row 1 of column 'COMPNAME' +from the file 'graph.tab' to the header of the +table 'thruput.tab'. If the keyword does not already exist, then add +it: + +.nf +tt> tabkey graph.tab COMPNAME 1 thruput.tab COMPNAME add+ +.fi + +2. Copy the date of the tenth observation (i.e., row 10 of column 'DATE') +from the file 'schedule.tab' to the +header keyword 'DATE' in 'image.hhh'. The keyword 'DATE' must already exist: + +.nf +tt> tabkey schedule.tab DATE 10 image.hhh date +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +keypar, keytab, parkey, partab, tabpar +.endhelp diff --git a/pkg/utilities/nttools/doc/tabpar.hlp b/pkg/utilities/nttools/doc/tabpar.hlp new file mode 100644 index 00000000..8a5b9ffb --- /dev/null +++ b/pkg/utilities/nttools/doc/tabpar.hlp @@ -0,0 +1,95 @@ +.help tabpar May2002 tables +.ih +NAME +tabpar -- Copy a table element to an IRAF parameter. +.ih +USAGE +tabpar table column row +.ih +DESCRIPTION +This task reads a table element specified by a table name, column name, +and row number. The element is written to the task parameter 'value' as +a character string. If the table element is boolean, then 'value' will +be either "yes" or "no". If the element is undefined, the task parameter +'undef' will be set to "yes". String parameters, such as 'value', can be +converted to numeric types with the built in functions real() and int(). +.ih +PARAMETERS +.ls table [file name] +Name of the table from which this task is to read a value. +.le +.ls column [string] +Column name. (The column name is not case sensitive.) +.le +.ls row [integer, min=1, max=INDEF] +Row number. +.le +.ls (format=yes) [boolean] +Format the value using table print format? + +The value from the table is returned to this task as a string parameter +(see 'value'). +The default is to use the print format for 'column' to format the value, +because this preserves the behavior of the task +prior to the addition of the 'format' parameter. +This behavior may be desirable when using h or m format, for example, +or perhaps when using x or o format. +On the other hand, +it will often be the case that what you want is +the actual value in the table, +and using the print format +could significantly limit the accuracy of the result. +In this case, use format=no. +.le +.ls (value) [string] +This parameter is used to store the value read in from 'table'. +.le +.ls (undef) [boolean] +Is the value read in from 'table' undefined? +.le +.ih +EXAMPLES +1. Print the interval between the first 2 wavelengths (i.e., rows 1 and 2 +in the column 'WAVELENGTH') in the table 'spectrum.tab': + +.nf +tt> tabpar spectrum.tab WAVELENGTH 1 +tt> x = real(tabpar.value) +tt> tabpar spectrum.tab WAVELENGTH 2 +tt> y = real(tabpar.value) +tt> print(y-x) +.fi + +2. Print the twelfth component name (i.e., row 12 of the column 'COMPNAME', +after checking to see if it is undefined. If the value is undefined, then +print a message instead: + +.nf +tt> tabpar graph.tab COMPNAME 12 +tt> if (tabpar.undef) { +>>> print ("Component name undefined") +>>> } else { +>>> print ("Component name = ",tabpar.value) +>>> } +.fi + +3. Here is an example illustrating the difference between +format=yes and format=no for an integer column with x (hexadecimal) format: + +.nf +tt> tabpar g.tab counts 4 format=yes +tt> =tabpar.value +31 +tt> tabpar g.tab counts 4 format=no +tt> =tabpar.value +49 +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +keypar, keytab, parkey, partab, tabkey +.endhelp diff --git a/pkg/utilities/nttools/doc/taextract.hlp b/pkg/utilities/nttools/doc/taextract.hlp new file mode 100644 index 00000000..50e34dbe --- /dev/null +++ b/pkg/utilities/nttools/doc/taextract.hlp @@ -0,0 +1,109 @@ +.help taextract Jan98 tables +.nj +.ih +NAME +taextract -- Copy an array entry from one table +to a column of scalars in another. +.ih +USAGE +taextract intable outtable row column +.ih +DESCRIPTION +This task extracts one entry (presumably an array of values) +at a specified row and column +and writes it as a column of scalar values to another table. +If the output table exists it will be written to in-place; +otherwise, it will be created. + +By default, the same column name is used in both tables. +If the output table and column already exist, +the data in that column will be overwritten; +otherwise, the column will be created. +If the array size for the specified column in the input table is N, +then the values will be written to rows 1 through N of the output table. +If the output column already exists, +and the output table contains more than N rows, +then rows N+1 through the last will be set to INDEF for this column. + +The input row number is written to the header of the output table +using keyword ORIG_ROW. +This allows 'tainsert' to put the data back where 'taextract' got them from. +.ih +PARAMETERS +.ls intable [file name] +Name of the input table containing a column with array entries. +It is not an error for the array length to be one. +.le +.ls outtable [file name] +Name of the output table. +If this table doesn't exist it will be created. +If the table does exist the column will either be created or overwritten. +The input and output tables may not be the same, +and they may not be in the same file if FITS format is used. +.le +.ls row [integer, min=1, max=INDEF] +This is the row number in the input table. +In the output table there will be as many rows +as there are elements in the input table entry for 'column'. +.le +.ls column [string] +Column name. +This is used to find the column in the input table, +and by default the same name is used to create +(or find, if it already exists) +the column in the output table. +See the description for 'outcolumn'. +.le +.ls outcolumn = "" [string] +If 'outcolumn' is specified, +that name will be used for the output table; +otherwise, 'column' will be used for both input and output tables. +This provides an easier way to change the name of the output column +than by running 'tchcol' after running 'taextract'. +Note that if 'outcolumn' is specified, +it is used not only for finding the column in the output table +but also for creating the column if it wasn't found. +The 'datatype', 'colunits', and 'colfmt' parameters, by contrast, +are only used when creating a new column. +.le +.ls (datatype = "") [string] +When creating a new column in the output table, +the default is to use the same data type as the column in the input table. +However, if 'datatype' is specified (i.e. not null or blank), +this will be used as the data type when creating the new column. +For numeric and boolean columns, only the first character is used: +"r" and "d" for single and double precision floating point, +"s" and "i" for short integer and integer, +"b" for boolean. +For a character string of maximum length 12 (for example), use "ch*12". +.le +.ls (colunits = "") [string] +When creating a new column in the output table, +the units will be set to 'colunits' if it has been specified; +otherwise, the units will be copied from the column in the input table. +.le +.ls (colfmt = "") [string] +When creating a new column in the output table, +the print format will be set to 'colfmt' if it has been specified; +otherwise, the print format will be copied from the column in the input table. +.le +.ih +EXAMPLES +1. Extract the array from row 5, column "polar", from table "array.tab", +putting the values in column "polar" of table "scalar.tab". + +.nf +at> taextract array.tab scalar.tab 5 polar +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +tainsert + +Type "help ttools opt=sysdoc" for a higher-level description of the 'ttools' +package. +.endhelp diff --git a/pkg/utilities/nttools/doc/tainsert.hlp b/pkg/utilities/nttools/doc/tainsert.hlp new file mode 100644 index 00000000..3d07855b --- /dev/null +++ b/pkg/utilities/nttools/doc/tainsert.hlp @@ -0,0 +1,132 @@ +.help tainsert Jan98 tables +.nj +.ih +NAME +tainsert -- Copy a column of scalars from one table +to an array entry in another. +.ih +USAGE +tainsert intable outtable row column +.ih +DESCRIPTION +This task reads an entire column from one table +and inserts those values (presumably more than one) +at a specified row and column in an output table. +If the output table exists it will be written to in-place; +otherwise, it will be created. + +By default, the same column name is used in both tables. +If the column does not exist in the output table, the column will be created. +If the output table and the row and column already exist, +the array of values at that location will be overwritten. +The number of elements copied will be the minimum of +the number of input rows and the output column array size. +If the number of input rows is larger than the array size, +a warning message will be printed, +and the extra rows will be ignored. +If the number of input rows is smaller than the array size, +the remaining array elements will be set to INDEF. + +If the specified row number is less than one or is INDEF, +'tainsert' looks for the header keyword ORIG_ROW in the input table. +ORIG_ROW is written by 'taextract'. +If that keyword exists, its value is used as the row number. +.ih +PARAMETERS +.ls intable [file name] +Name of the input table. +.le +.ls outtable [file name] +Name of the output table. +If this table doesn't exist it will be created. +.le +.ls row = -1 [integer] +This is the row number in the output table. +The default means that 'tainsert' should use +the value of the header keyword ORIG_ROW. +.le +.ls column [string] +Column name in the input table and, by default, also in the output table. +If this column does not exist in the output table, it will be created, +and the array size will be set to the number of rows in the input table. +See the descriptions for 'outcolumn' and 'size', however. + +It is an error if this column in the input table contains array entries. +.le +.ls outcolumn = "" [string] +If 'outcolumn' is specified, +that name will be used for the output table; +otherwise, 'column' will be used for both input and output tables. +This provides an easier way to change the name of the output column +than by running 'tchcol' after running 'taextract'. +Note that if 'outcolumn' is specified, +it is used not only for finding the column in the output table +but also for creating the column if it wasn't found. +The 'size', 'datatype', 'colunits', and 'colfmt' parameters, +by contrast, are only used when creating a new column. +.le +.ls (size = INDEF) [int] +When creating a new column in the output table, +the default is for the array size of that column to be set to +the number of rows in the input table. +This may be overridden by specifying a value for 'size'. +If 'size' is a positive integer, not INDEF, +this will be used as the array size when creating the new column. +.le +.ls (datatype = "") [string] +When creating a new column in the output table, +the default is to use the same data type as the column in the input table. +However, if 'datatype' is specified (i.e. not null or blank), +this will be used as the data type when creating the new column. +For numeric and boolean columns, only the first character is used: +"r" and "d" for single and double precision floating point, +"s" and "i" for short integer and integer, +"b" for boolean. +For a character string of maximum length 12 (for example), use "ch*12". +.le +.ls (colunits = "") [string] +When creating a new column in the output table, +the units will be set to 'colunits' if it has been specified; +otherwise, the units will be copied from the column in the input table. +.le +.ls (colfmt = "") [string] +When creating a new column in the output table, +the print format will be set to 'colfmt' if it has been specified; +otherwise, the print format will be copied from the column in the input table. +.le +.ih +EXAMPLES +1. Copy the entire column "polar" from table "scalar.tab", +and insert the values into row 5, column "polar", of table "array.tab". +If "array.tab" does not exist it will be created. +If column "polar" does not exist in "array.tab", +that column will be created. + +.nf +at> tainsert scalar.tab array.tab 5 polar +.fi + +2. Copy the arrays from row 5, columns "wavelength" and "flux", +from "array.tab" to a temporary table, +sort them on the wavelength, +and insert them back where they came from. + +.nf +at> taextract array temp 5 wavelength +at> taextract array temp 5 flux +at> tsort temp wavelength +at> tainsert temp array 0 wavelength +at> tainsert temp array 0 flux +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +taextract + +Type "help ttools opt=sysdoc" for a higher-level description of the 'ttools' +package. +.endhelp diff --git a/pkg/utilities/nttools/doc/tcalc.hlp b/pkg/utilities/nttools/doc/tcalc.hlp new file mode 100644 index 00000000..10b5415d --- /dev/null +++ b/pkg/utilities/nttools/doc/tcalc.hlp @@ -0,0 +1,153 @@ +.help tcalc Jan92 ttools +.ih +NAME +tcalc -- Perform arithmetic operations on table columns. +.ih +USAGE +tcalc table outcol equals +.ih +DESCRIPTION +This task evaluates an arbitrary expression that includes column names, +constants, and operators, and creates a specified column in the +table---or overwrites an existing column if the specified name already exists. +Variables in the expression are column names in either case. + +Columns +may be of any type except string. If the column name contains +non-alphanumeric characters, it should be preceded by a dollar sign +and followed by a blank. For example, the expression "date-obs+1." +contains the column "date-obs", but the task thinks that it contains +two column names, "date" and "obs". To ensure that the expression is +evaluated correctly, rewrite it as "$date-obs +1.". The variable +"rownum" may also be used in an expression if there is no column in +the table of the same name. Its value is the current row number. The +expression will be evaluated using the data types of the columns and +constants in the expression, with the usual rules of type promotion used in +Fortran. Please remember that integer division truncates. + +The output value in any row will be set to INDEF if one or more column +values used in the calculation is equal to INDEF. The result will be +INDEF if either of the clauses in an if expression contains a row with +an INDEF value. If the result of an operation is undefined (such as +division by zero) the output column will also be set to INDEF. + +The following Fortran-type arithmetic operators are supported. If the +second argument of the exponentiation is not an integer, the result +will be undefined if the first argument is not positive. Again, +remember that integer division truncates. + +.nf ++ addition - subtraction +* multiplication / division +- negation ** exponentiation +.fi + +The following logical operators are supported. Logical operators will +return a value of 1 if true or 0 if false. Logical operators are +supported in both their Fortran and SPP form. + +.nf +.or. || logical or .and. && logical and +.eq. == equality .ne. != inequality +.lt. < less than .gt. > greater than +.le. <= less or equal .ge. >= greater or equal +.not. ! not +.fi + +The following functions are supported. These functions all take a +single argument, which may be an expression. The argument or result of +trigonometric functions are in radians. + +.nf +abs absolute value acos arc cosine +asin arc sine atan arc tangent +cos arc cosine cosh hyperbolic cosine +cube third power double convert to double +exp E raised to power int convert to integer +log natural logarithm log10 common logarithm +nint nearest integer real convert to real +sin sine sinh hyperbolic sine +sqr second power sqrt square root +tan tangent tanh hyperbolic tangent +.fi + +The following functions take two arguments. + +.nf +atan2 arc tangent dim positive difference +max maximum min minimum +mod modulus sign sign transfer +.fi + +Conditional expressions of the form "if expr then expr else expr" are +supported. The expression after the else may be another conditional +expression. The words "if", "then", and "else" must be surrounded by +blanks. +.ih +PARAMETERS +.ls table [file name template] +The input table, or tables; these files are modified in-place. +Results will be written to a new column in the table unless an +existing column name is specified, in which case the existing values +will be overwritten. +.le +.ls outcol [string] +Output column name. This is the column where results are written. +Caution: if this column already exists, then it will be overwritten +with the results of the calculation. Note that column names are not +case sensitive. +.le +.ls equals [string] +The arithmetic expression to evaluate. If the expression is too long +to pass as a parameter, place the expression in a file and set the +value of this parameter to the file name preceded by an "@", for +example, "@filename". +.le +.ls (datatype = real) [string, allowed values: real | double | int ] + +Type of data stored in the output column, if it is a new column. +.le +.ls (colunits) [string] +Units for the output column, if it is a new column. This parameter +may be blank. +.le +.ls (colfmt) [string] +Print format for the output column, if it is a new column. If this +parameter is left blank then a default will be used. Type "help +ttools opt=sysdoc" for more information about print formats. +.le +.ih +EXAMPLES +1. Create a column called 'FLUX', which will contain a value equal to +10.0**(-x/2.5) where x is the value in the column 'MAG'. The new +column will contain single precision data. + +.nf +tt> tcalc "intab" "FLUX" "10.0**(-mag/2.5)" +.fi + +2. Create a column called 'POLY', which will contain a value equal to +x+x**2 where x is the row number in the table. + +.nf +tt> tcalc "test" "POLY" "rownum+sqr(rownum)" +.fi + +3. Set quotient to zero where divison by zero would otherwise occur: + +.nf +tt> tcalc "test" "QUOT" "if y != 0 then x / y else 0." +.fi + +.ih +BUGS +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +imcalc + +Type "help ttools opt=sys" for a higher-level description of the 'tables' +package. +.endhelp diff --git a/pkg/utilities/nttools/doc/tchcol.hlp b/pkg/utilities/nttools/doc/tchcol.hlp new file mode 100644 index 00000000..1a53c00c --- /dev/null +++ b/pkg/utilities/nttools/doc/tchcol.hlp @@ -0,0 +1,80 @@ +.help tchcol Jan92 tables +.nj +.ih +NAME +tchcol -- Change column description. +.ih +USAGE +tchcol table oldname newname newfmt newunits +.ih +DESCRIPTION +This task may be used to change the name of a column, the display +format, or the units. +To change more than one column the task must be called more than once. +Only those items (name, units, format) that are not null will be changed. +The word "default" may be used to set +the print format or the units to their default values. +.ih +PARAMETERS +.ls table [file name template] +Names of tables to be modified. +The same change(s) will be made to all tables. + +Note that the tables are modified in-place. +.le +.ls oldname = "" [string] +Name of column to be changed. +If the column is not found, +a message will be printed, +and the current table will not be changed. +.le +.ls newname = "" [string] +New column name or a null string (""). + +If this is null or blank, the column name will not be changed. +.le +.ls newfmt = "" [string] +New value for print format, or "default" or "". + +If this is null or blank, the display format will not be changed. +If 'newfmt = "default"' the print format will be set to the default +for the column data type. +Type "help ttools opt=sysdoc" for more information about print formats. +.le +.ls newunits = "" [string] +New value for units, or "default" or "". + +If this is null or blank the units will not be changed. +If newunits = "default" the units will be set to null. +There is no way (with this task) to set the units to the value "default"! +.le +.ls (verbose = yes) [boolean] +Print the names of tables as the task progresses? + +If 'verbose=yes' then the table names are printed, +and for each item that is changed, a message is printed +giving the old and new values. +.le +.ih +EXAMPLES +In table 'm87pol.tab', change column name "chi" to "CHI" and set the units +to degrees. The display format is not changed. + +.nf +tt> tchcol m87pol chi CHI "" degrees +.fi + +In the same table, set the units of column "P" to null. +The name and format are not changed. + +.nf +tt> tchcol m87pol P "" "" default +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by J.C. Hsu and was modified by Phil Hodge. +.ih +SEE ALSO +.endhelp diff --git a/pkg/utilities/nttools/doc/tcheck.hlp b/pkg/utilities/nttools/doc/tcheck.hlp new file mode 100644 index 00000000..e9cb3e89 --- /dev/null +++ b/pkg/utilities/nttools/doc/tcheck.hlp @@ -0,0 +1,137 @@ +.help tcheck Aug91 tables +.ih +NAME +tcheck -- Check STSDAS table values. +.ih +USAGE +tcheck input chkfile +.ih +DESCRIPTION +This task allows the user to check the correctness of an STSDAS table by +printing the rows, column names, and values of selected table +elements. The table elements selected are controlled by lines in the +check file. Table elements are printed by placing their names on a +line in the check file followed by the word "when" and a logical +expression. The values of all columns listed before the "when" will be +printed for each row for which the expression is true. For example, + +.nf +ylower, yupper when ylower >= yupper +.fi + +prints the values of the columns 'ylower' and 'yupper' for any row +where 'ylower' is greater than or equal to 'yupper'. If the column names +and expression are too long to fit on a line, the line can be +continued by placing a backslash as the last character on the line. +Lines which are blank, or start with a comment character (#), are +ignored. + +An expression may contain table column names and string or numerical +constants. The table column names may be in either lower or upper +case. If "when" is a column name, place it in upper case so its +meaning will not be ambiguous. String constants may be surrounded by +either single or double quotes. Numeric constants will be treated as +real numbers if they contain a decimal point or integers if they do +not. + +The expression must have a boolean (logical) value. Boolean operators +can be used in an expression in either their SPP or Fortran form: + +.nf +equal == .eq. not equal != .ne. +less than < .lt. less than or equal <= .le. +greater than > .gt. greater than or equal >= .ge. +or || .or. and && .and. +negation ! .not. +.fi + +The expression may also include the usual arithmetic operators and +functions. Arguments to the trigonometric functions must be in +degrees. The available operators are: + +.nf +addition + subtraction - +multiplication * division / +negation - exponentiation ** +string concatenation // +.fi + +Three new functions are available in addition to the usual arithmetic +functions: +.nf + +row takes no argument, returns current row number +delta takes two dates (in CDBS format) and returns the + number of days between them +match returns true if the first argument matches one or more + of the remaining arguments of the function (the arguments + may be of any type, as long as all arguments have the + same type. +.fi + +The +following is a list of the available functions: + +.nf +absolute value abs(x) cosine cos(x) +sine sin(x) tangent tan(x) +arc cosine acos(x) arc sine asin(x) +arc tangent atan(x) arc tangent atan2(x,y) +exponential exp(x) square root sqrt(x) +natural log log(x) common log log10(x) +minimum min(x,y) maximum max(x,y) +modulo mod(x,y) row number row() +date difference delta(x,y) equality match (x,y,z,...) +.fi + +.ih +PARAMETERS +.ls input [file name template] +List of tables that will be checked. +.le +.ls chkfile [file name] +Text file containing consistency checks. +.le +.ih +EXAMPLES +1. The simplest check is when a table element has one legal +value. This can be tested for as follows. + +.nf +overscan when overscan != 5 +.fi + +2. A range of values can also be tested, as in the following expressions. + +.nf +aper_area when aper_area <= 0.0 +pass_dir when detnum < 1 || detnum > 2 +.fi + +3. If a keyword has several legal values and they do not form a range, it +may be easier to use the match function. + +.nf +fgwa_id when ! match(fgwa_id,"CAM","H13","H19","H27",\ +"H40","H57","H78") +.fi + +4. The value of one keyword may depend on the value of another. This can +be tested by combining the conditions with an "and": + +.nf +aper_pos when aper_id == 'A-1' && aper_pos != 'SINGLE' +polar_id when fgwa_id == 'CAM' && polar_id != 'C' +.fi + +.ih +BUGS +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +hcheck + +Type "help tables opt=sys" for a description of the 'tables' package. +.endhelp diff --git a/pkg/utilities/nttools/doc/tchsize.hlp b/pkg/utilities/nttools/doc/tchsize.hlp new file mode 100644 index 00000000..fa9bbb96 --- /dev/null +++ b/pkg/utilities/nttools/doc/tchsize.hlp @@ -0,0 +1,158 @@ +.help tchsize Oct95 tables +.nj +.ih +NAME +tchsize -- Change the size of tables. +.ih +USAGE +tchsize intable outtable maxpar maxcols rowlen allrows +.ih +DESCRIPTION +This task changes the allocated sizes of various portions of a table +or a list of tables. +In some cases it is difficult to effectively use this task, +so caution is advised. + +NOTE: This task should not be used on FITS tables. +If any input table is of type FITS, +a message will be printed, and that file will be skipped. + +Four integer parameters specify table sizes. +Passing a value of -1 to any parameter means that the current value +should not be changed. A value (such as zero) that is smaller than +the minimum allowed value for that parameter results in the truncation +of unused space; for example, if three header parameters have already +been written to a table then setting 'maxpar=0' gives you a table with +space for only three header parameters. + +The input may be a general filename +template, including wildcard characters or the name of a list file (preceded +by an "@" sign) containing table names. The output may be null, a directory +specification, or a list of table names. If the output is a list of tables +then there must be the same number of names in the input and output lists, +and the names are taken in pairs, one from input and one from output. +A null string for the output is equivalent to specifying the same names +for the input and output tables. + +NOTE: Be careful when using a wildcard for the extension. +If you have the files 'table.tab' and 'table.lis' in the current directory, +for example, then "tchsize tab* test/" would crash when trying to open +'table.lis' as a table. +.ih +PARAMETERS +.ls intable [file name template] +A list of one or more tables whose sizes are to be changed. +.le +.ls outtable = "" [file name template] +Either a null string, a directory name, or a list of output table names. +.le +.ls maxpar = -1 [integer] +The number of records to allocate for header (i.e., user) parameters. + +Use 'maxpar=-1' if no change is to be made; set 'maxpar=0' to +truncate unused space. +.le +.ls maxcols = -1 [integer] +The amount of space to allocate for column descriptors. There must be +at least one for each column that is defined or is to be defined. +For a column-ordered table 'maxcols' actually determines the maximum +number of columns that may be defined (without having to rewrite the +table). For a row-ordered table, however, you must also specify an +appropriate value for 'rowlen'; you may want to use the 'tinfo' task +to get the +current row length before using this task. + +Set 'maxcols=-1' if no change is to be made; set 'maxcols=0' +to truncate unused space. +.le +.ls rowlen = -1 [integer] +The row length; this is only relevant for a row-ordered table. +The unit of length is the amount of memory used to store +a real number; so a double-precision column +takes two units, and a character*24 column takes six units (assuming +that a real +is four bytes). +The number of columns that may be defined is limited both by the +space allocated for column descriptors and by the row length. + +Set 'rowlen=-1' if no change is to be made; set 'rowlen=0' +to truncate unused space. +.le +.ls allrows = -1 [integer] +The number of rows to allocate; this is only relevant for a column-ordered +table. + +Set 'allrows=-1' if no change is to be made; set 'allrows=0' to truncate +unused space. +.le +.ls (verbose = yes) [boolean] +Display the names of the input and output tables for each table that is +processed? +.le +.ih +EXAMPLES +1. Truncate (in-place) all unused space in a single table: + +.nf + tt> tchsize table "" 0 0 0 0 + or + tt> tchsize table table 0 0 0 0 +.fi + +2. Set the allocated space for user (header) parameters to 27 records +without changing any other size parameter. The result is to be put +in a new file called 'table2.tab', leaving the input table unchanged. + + tt> tchsize table table2 27 -1 -1 -1 + +3. Truncate unused space in three different tables, with the truncated tables +named 'a.tab', 'b.tab', and 'c.tab': + +.nf + tt> tchsize table1,table2,tab67 a,b,c 0 0 0 0 + or + tt> tchsize tab*.tab a,b,c 0 0 0 0 +.fi +In the latter case the extension is given explicitly in case there +are other files beginning with 'tab' that are not tables; there must +be exactly three tables beginning with tab because the output list +has three names. + +4. Increase the space available for allocating new columns: + +Suppose the following information about the table has been obtained +by using the 'tinfo' task: + +.nf + tinfo.ncols = 7 + tinfo.maxcols = 8 + tinfo.rowlen = 12 + tinfo.rowused = 10 + tinfo.tbltype = "row" +.fi + +Suppose we want to add 10 more columns: five single-precision columns, +two double-precision, and three character*12. If the table were +column-ordered we would only have to increase 'maxcols' to at least 17 +('ncols'+10). Since the table is row-ordered we still must have 'maxcols=17', +but we also have to increase the row length to allow room for the +additional columns. The extra row length needed is 5 + 2*2 + 3*3 = 18, +so we must set the new row length to at least 'tinfo.rowused' + 18 = 28. +So we have + +.nf + tt> tchsize table "" -1 17 28 -1 +.fi + +if the space for header parameters does not need to be changed, and +the allocated number of rows is irrelevant for a row-ordered table. + +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +tinfo +.endhelp diff --git a/pkg/utilities/nttools/doc/tcopy.hlp b/pkg/utilities/nttools/doc/tcopy.hlp new file mode 100644 index 00000000..a7ac05d7 --- /dev/null +++ b/pkg/utilities/nttools/doc/tcopy.hlp @@ -0,0 +1,113 @@ +.help tcopy Jan2001 tables +.nj +.ih +NAME +tcopy -- Copy tables. +.ih +USAGE +tcopy intable outtable +.ih +DESCRIPTION +This task is used to copy tables. The input may be a general filename +template, including wildcard characters or the name of a file (preceded +by an @ sign) containing table names. The output may be either a directory +specification or a list of table names. If the output is a list of tables +then there must be the same number of names in the input and output lists, +and the names are taken in pairs, one from input and one from output. +The input and output tables must not be the same. +This task will convert the format of the table +if the output filename extension indicates it. +For example, if the output filename extension is ".fits", +the output table will be a fits file. +If the output is redirected or piped, +it will be written to a text table. + +NOTE: Be careful when using a wildcard for the extension. +If you have the files "table.tab" and "table.lis" in the current directory, +for example, then the command "tcopy tab* test/" would copy both files +to the subdirectory "test". +.ih +PARAMETERS +.ls intable [file name template] +A list of one or more tables to be copied. +.le +.ls outtable [file name template] +Either a directory name or a list of output table names. + +If 'outtable' is not a directory, +the number of input tables and output tables must be the same. +An exception to this rule is that if 'outtable' is a FITS file +(i.e. an existing FITS file, or the name ends in ".fits") +then multiple input tables can be copied to one output file. +.le +.ls (verbose = yes) [boolean] +Display names of input and output tables as they are copied? +.le +.ih +EXAMPLES +1. To simply copy a table: + +.nf + tt> tcopy table.tab tablecopy.tab +.fi + +2. To copy one or more tables, possibly changing table type: + +.nf + tt> tcopy table1.tab,table2.tab a.fits,b.tab + tt> tcopy a.fits,b.tab a.tab,b.fits + tt> tcopy a.fits > a.txt +.fi + +The number of input and output tables must be the same. +In the third case, +"a.txt" will be a text file because +the output table name was "STDOUT" +(the name was implicitly set, in this case, +because the output was redirected.) + +3. To copy a set of tables to a new directory: + +.nf + tt> tcopy table*.tab directory + or + tt> tcopy table*.tab directory$ + or + tt> tcopy table*.tab osdirectory +.fi + +where "directory" is an IRAF environment variable for a directory name, +and "osdirectory" is an operating system directory name +(e.g., "/user/me/" in UNIX). + +4. To copy only specified extensions of a FITS file: + +.nf + tt> tcopy xyz.fits[3],xyz.fits[5] b.fits +.fi + +If "b.fits" did not already exist, +it would be created and would then contain two table extensions. +If it did already exist, +the two extensions would be appended. +Note that the number of input and output files are not the same; +this is OK because the output is a FITS file +and can therefore contain multiple table extensions. + +5. The input and/or output may be redirected: + +.nf + tt> dir l+ | tproject columns=c7,c3 | tcopy dir.tab > verbose.lis +.fi + +"verbose.lis" contains just the one line "# STDIN -> dir.tab", +and "dir.tab" has the output of 'tproject', the file names and sizes. +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +tdelete +.endhelp diff --git a/pkg/utilities/nttools/doc/tcreate.hlp b/pkg/utilities/nttools/doc/tcreate.hlp new file mode 100644 index 00000000..0d12d277 --- /dev/null +++ b/pkg/utilities/nttools/doc/tcreate.hlp @@ -0,0 +1,378 @@ +.help tcreate Dec2003 tables +.nj +.ih +NAME +tcreate -- Create a table from ASCII files describing a table format. +.ih +USAGE +tcreate table cdfile datafile +.ih +DESCRIPTION +This task reads an ASCII file containing column descriptions for a new table. +The columns are defined and the table created; +data are read in from a file specified by +the 'datafile' parameter +(a specified number of lines may be skipped when reading in data). +There may be several lines of data per table row. +Blanks and tabs are skipped. +Blank lines and lines beginning with # are ignored. +In-line comments using # are permitted. +The lines in the input files may be up to 8195 characters long, +plus one character for the carriage return. +The input 'datafile' is read free-format. + +Undefined values require a place holder in the data file. +The word INDEF should be used as the place holder +for undefined (indefinite) numerical values, +the word "no" for boolean values, +and a pair of adjacent quotes ("") for undefined character strings. +If a value for a character string contains one or more blanks, +or the comment character (#), +then the entire value must be enclosed in quotes, e.g., "R CrB". + +This task can also read a file containing header parameters for the table. + +If a problem occurs when reading a particular data field, +the execution continues, and the table entry is marked as undefined. +.ih +PARAMETERS +.ls table [file name] +Output file name for the table created by this task. + +Note that, if 'table' is an existing FITS file, +the table that is created will be appended +as a new extension to the end of the file. +.le +.ls cdfile = STDIN [file name] +The name of the column definition file. + +The column definition file contains one line for each column to be created. +Each line contains up to four values giving attributes of the particular column. +Every line must have a column name; optionally, it may have a data type, +display format, and units. (Embedded blanks in any of these +attributes must be enclosed in quotes.) Adjacent quotes are used as +place holders and let you skip an attribute while defining the next one. +Column names and data types are NOT case sensitive. +Neither the format nor data type may contain embedded blanks. +Display formats may be of the type used by Fortran or those used by SPP. +If the format is not defined, a default format will be used. +The format is not used for internal representation of the data and +is ignored when reading data---it is used only for display purposes, +for example, by tasks such as 'tedit', 'tread', and 'tprint'. +Type "help ttools opt=sysdoc" for detailed information about print formats. +Comment lines may be included in this file +by beginning the line with the comment symbol (#). + +The following data types are recognized by this parameter +(the default data type is single-precision real): +.nf + + r - Single-precision real. + d - Double-precision real. + i - Integer. + s - Short integer. + b - Boolean. + ch*n - Character string of maximum length n. +.fi + +A column of arrays can be created by giving the array length +in square brackets appended to the data type. +For example, a data type of r[400] would mean that the column +contains an array of 400 single-precision real numbers in each row. +r[20,5,4] would also mean an array of 400 reals, +but in this case a TDIMi keyword will be written (for column number i) +that gives the numbers 20, 5 and 4, +indicating that the array should be regarded as 3-D, +with 20 elements along the most rapidly varying axis +and four elements along the least rapidly varying axis. +Up to seven dimensions may be specified, separated by commas. +For both of these cases, the data file must contain 400 values +for that column for each row; +the values need not all be on the same line of the data file. +Text tables and column-ordered stsdas tables +cannot contain arrays; see 'tbltype'. + +If you have an existing table +with columns similar to those +in the table you would like to create, +you can use the 'tlcol' task to generate a file +which can be edited and used as the input 'cdfile' for 'tcreate'. +That is, the output of 'tlcol' is exactly the format +that is expected for 'tcreate.cdfile'. +The syntax is also the same as +for column definitions in text tables, +except for the leading "#c " in text tables. + +If cdfile = "STDIN" and the input is not redirected, +the task prints a prompt asking for input. +Press Control-Z (or Control-D, i.e. your EOF character) +to terminate the list of column definitions; +note that the Control-Z must NOT occur on the same line as the last +column definition. +.le +.ls datafile = "STDIN" [file name] +The name of the input ASCII data file. + +The values in the file must be in the order of the columns +as given in the column-definitions file 'cdfile'. +Undefined values should have INDEF or "" as place holders +for numerical or character values, respectively. +Each row for the table must begin with a new line in 'datafile', +but there can be multiple lines in 'datafile' for each table row +(see also 'nlines'). + +If all data for a table row have been read from an input line +but there are additional data on the line, +or if there is a data type mismatch, +the following warning will be +printed: "out of synch or extra data in line ". + +Lines in the input data file are limited to 8196 characters, +including the newline at the end of each line. +If a longer line is encountered, the task will stop with an error. + +As with 'cdfile', +if datafile = "STDIN" and the input is not redirected, +the task prints a prompt asking for input. +Enter a carriage return before ending the last line +and then press Control-Z (or Control-D, i.e. EOF) to close the file. +.le +.ls (uparfile) [file name] +The name of the input ASCII file of header parameters. +This file is optional. + +Each line of this file defines one header parameter, +except that blank lines and lines beginning with # will be ignored. +Each line should contain three parts: keyword, datatype, and value; +an optional comment may be added following the value. +The keyword is a string (no embedded blanks) of up to eight characters. +The datatype is a single letter (t, b, i, r, or d) that indicates the type. +The value is limited to 70 characters. +If the type is text (t) it may contain more than one word, +but in that case it must be enclosed in quotes; +otherwise, the portion of the value following the first word +will be interpreted as a comment. + +Note that the syntax is not the same as +for header keywords in text tables. +The latter uses the much more reasonable "#k keyword = value comment". +The datatype shouldn't need to be specified, +since keywords are stored in the table as text strings anyway; +the current syntax has been retained for backward compatibility. + +It is possible, though not recommended, to set uparfile = "STDIN". +The problem is that it is read twice, +once just to count the number of entries, and once to read the values, +so you would have to type in the values twice. +.le +.ls (nskip = 0) [integer, min=0, max=INDEF] +Number of lines to skip at the beginning of the data file. + +The 'tcreate' task will also skip blank lines and lines beginning with #; +it will therefore not usually be necessary to specify 'nskip', +as header lines may be commented out by inserting a leading #. +Note that if 'nskip > 0' then exactly 'nskip' lines will be skipped, +even if some of them are blank or comment lines. +.le +.ls (nlines = 0) [integer, min=0, max=INDEF] +The number of lines in the input data file +corresponding to one row in the output table. +If 'nlines = 0' (the default) then lines will +be read from the data file until every column in the row is filled. +If 'nlines > 0' then exactly this many lines will be read for each row; +if for some rows the input data are compressed into fewer than this +many lines, extra dummy lines must be included following the good data. +Note that comment lines and blank lines are not counted. +.le +.ls (nrows = 0) [integer, min=0, max=INDEF] +The number of rows to write into the table. + +If this value is zero, then the entire input data file will be read. +If this value is greater than zero then +no more than 'nrows' will be written to the table, +even if the data file contains enough data to fill more than +'nrows' rows of data. +For a column-ordered table (see the 'tbltype' parameter), +'nrows' is the number of rows that will be allocated, +and the actual number in the data file may be smaller. +.le +.ls (hist = yes) [boolean] +Add a history record containing a creation date? + +If 'hist = yes', a header parameter will be written to the table with the +keyword 'HISTORY' that gives the date and time that 'tcreate' was run. +This parameter is added after those that were read from the 'uparfile', if any. +.le +.ls (extrapar = 5) [integer, min=0, max=INDEF] +Extra space to be reserved for header-parameter records. +This is the number of records for header parameters that will be allocated, +in addition to the number needed to hold the parameters +specified in the 'uparfile' parameter file. +The default is five, +which means that after the table is created +up to five more parameters may be added +(e.g., by using the 'tupar' task) +without the table being rewritten to reallocate space. +.le +.ls (tbltype = "default") [string, allowed values: default | row | +column | text] +Type of table to create. +The default is row-ordered stsdas format. +To create a FITS table, +use tbltype = "default" +and specify a table name ('table') +with filename extension ".fits", ".fit", or ".??f" +('?' is any single character). +.le +.ls (extracol = 0) [integer, min=0, max=INDEF] +Extra space to be reserved for columns in the output table. +This parameter is relevant only for a row-ordered stsdas format table. + +This is in addition to the number required to contain those columns +described by 'cdfile'. +One unit of space is taken by each +single-precision, integer, or boolean column. +A double-precision column requires two units of allocated space, +and a character-string column takes one unit of space for each four +characters, or fraction thereof. +.le +.ih +EXAMPLES +1. Wait for the user to type in column definitions and data, +each of which will be terminated by a Control-Z (or Control-D, i.e. EOF). +The prompts are printed by the 'tcreate' task; +these are the lines beginning with "Give column definitions" +and "Give table data". +The table will have 4 columns and 2 rows. +.nf + +tt> tcreate test STDIN STDIN + +Give column definitions (name, datatype, print format, units) + ... then newline & EOF to finish. +name ch*12 +ra d h12.1 hours +dec d h12.0 degrees +mag r f8.2 +^Z + +Give table data ... then newline & EOF to finish. +nameless 3:18:47 42:24 INDEF +"SA0 123456" 19:00:06.3 -0:00:01 3.5 +^Z + +.fi +2. Create a table called "outfile.tab" using the columns specified +in "columns.cd" and the data in "data.dat". + +tt> tcreate outfile columns.cd data.dat nskip=3 + +"columns.cd" may contain just the following: +.sp +.nf +STARno I i5 +X r "F6.2" pixels +Y R F6.2 "pixels" +MAG R "" magnitude + SHARP R + ROUND r +STARNAME ch*15 +.fi + +Note the free format of, and embedded tabs in, the column definitions file +itself. The format for display of MAG is not specified, but the unit is +given as magnitude, so adjacent quotes are used to mark the position where +the display format is expected. + +The file "data.dat" may contain (if 'nskip=3', 'nlines=2'): +.sp +.nf +This is a header + header2 + header3 + 1 3.0 4.0 + 5.0 6.0 7.0 HD12345 + 2 10.0 11.0 12.0 13.0 +14.0 "HD 122" +3 20.0 21.0 22.0 23.0 24.0 "" +dummy line +.fi + +Note the tabbed and free format of the data file +and the specification of the character strings. +If the character data contain embedded blanks +then the whole string should be quoted, +otherwise this is not necessary. +The final entry is the null character string. + +3. The following column definitions: +.sp +.nf +STARno i i6 +X r f9.2 pixels +Y r f9.2 pixels +MAG r f9.3 +SHARP r f9.3 +ROUND r f9.3 +STARNAME ch*15 + +could be used with the following data file: + + 1 7.92 2.64 -3.075 0.436 0.019 XXXXXXXXXXXXXXX + 2 33.89 3.14 -1.162 0.419 0.223 + 3 3.68 5.07 -2.454 0.421 -0.123 HD12345 + 4 42.70 5.08 -1.285 0.445 0.195 HD 123 +.fi + +4. The aperture photometry file from the 'daophot' task +may have the following data: +.sp +.nf + 1 6.95 2.61 99.999 99.999 99.999 99.999 . . . + 464.618 9.71 0.52 9.999 9.999 9.999 9.999 . . . + 2 200.06 2.80 99.999 99.999 99.999 99.999 + 465.180 7.79 0.16 9.999 9.999 9.999 9.999 + 3 156.25 5.17 14.610 14.537 14.483 14.438 + 462.206 7.26 0.37 0.013 0.014 0.015 0.016 + + +and could have the following column-definition file: + +STARno i +X r +Y r +MAG1 r +MAG2 r +MAG3 r + . + . + . +MAG15 r +SKYMOD r +SKYSD r +.fi + +The following could be used as an input file to define header parameters. +.sp +.nf +comment t Created 1987 July 22 +NL i 2 +NX i 284 +NY i 492 +THRESH r 27.0 +AP1 r 3.0 +PH/ADU r 20.0 +RNOISE r 6.50 +BAD r 300.0 +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +Type "help ttools opt=sysdoc" for a higher-level description of the 'ttools' +package. +See also the files in "tables$doc/". +.endhelp diff --git a/pkg/utilities/nttools/doc/tdelete.hlp b/pkg/utilities/nttools/doc/tdelete.hlp new file mode 100644 index 00000000..43b9ee64 --- /dev/null +++ b/pkg/utilities/nttools/doc/tdelete.hlp @@ -0,0 +1,74 @@ +.help tdelete Aug93 tables +.nj +.ih +NAME +tdelete -- Delete a table. +.ih +USAGE +tdelete table +.ih +DESCRIPTION +This task deletes tables. +The input may be a general filename template, +including wildcard characters, or the name of a list file +(preceded by the "@" character) containing table names. + +The task checks that the file to be deleted really is a table +before deleting it. +In order to protect against accidental deletion of files other than tables, +text tables may be deleted using 'tdelete' only if 'verify = yes'. +.ih +PARAMETERS +.ls table [file name template] +A list of one or more tables to be deleted. +.le +.ls (verify = no) [boolean] +Prompt for confirmation before deleting? It is possible to delete +text tables using 'tdelete' if 'verify' is set to "yes". +.le +.ls (default_action = yes) [boolean] +Default action for the verify query. If 'default_action = yes', then the +prompt will come back with "yes?" and striking return will proceed with +the delete. +.le +.ls go_ahead = yes [boolean] +This is a copy of 'default_action' used for prompting if 'verify = yes'. +This parameter is set by the task, it copies the value of 'default_action', +but cannot be directly set by the user. +.le +.ih +EXAMPLES +1. Delete a single table. + +.nf + cl> tdelete table +.fi + +2. Delete several tables. + +.nf + cl> tdelete table1,table2,tab67 + cl> tdelete *.tab,a,b,c + +.fi +In the latter case, the extension is given explicitly because there may be +other files beginning with "tab" that are not tables. + +3. Delete a list of tables using verify. + +.nf + cl> tdelete fits*.tab ver+ + cl> delete table `fits1.tab' ? (yes): yes + cl> delete table `fits2.tab' ? (yes): yes + cl> delete table `fits3.tab' ? (yes): yes +.fi +.ih +BUGS +Text tables cannot be deleted by 'tdelete' unless 'verify' is set to yes. +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +delete, tcopy, trename +.endhelp diff --git a/pkg/utilities/nttools/doc/tdiffer.hlp b/pkg/utilities/nttools/doc/tdiffer.hlp new file mode 100644 index 00000000..915aa4c6 --- /dev/null +++ b/pkg/utilities/nttools/doc/tdiffer.hlp @@ -0,0 +1,65 @@ +.help tdiffer May92 tables +.ih +NAME +tdiffer -- Create a new table which is the difference of two tables. +.ih +USAGE +tdiffer intable1 intable2 outtable colnam1 colnam2 +.ih +DESCRIPTION +This task creates an output table containing all the rows of the first table +which do not match the rows in the second table. +The first, second, and output tables are given by the task +parameters 'intable1', 'intable2', and 'outtable' respectively. +The match is done on the columns specified by the task parameters 'colnam1' +and 'colnam2'. +Other columns are ignored. +If the two tables are disjoint, the output table will be a copy of +the first table, except the rows will be sorted. +If the first table is a subset of the second, the output table will be empty. +.ih +PARAMETERS +.ls intable1 [file name] +The name of the first input table. +.le +.ls intable2 [file name] +The name of the second input table. +.le +.ls outtable [file name] +The name of the output table. The output table has the same header parameters +and column names as the first table. +.le +.ls colnam1 [string] +The column names in the first table used in the match. If more than one +column is used, columns from the first and second +table are associated with each other based on their position in the list +and not on their names, i.e., the first column name in 'colnam1' is matched +to the first column name passed to 'colnam2', regardless of whether the +names match. +.le +.ls colnam2 [string] +The column names in the second table used in the match. The same number of +column names must be passed to both the 'colnam1' and 'colnam2' parameters. +.le +.ih +EXAMPLES +1. There are two tables, "targets.tab", containing a list of targets +for observation, and "images.tab", containing a list of targets which +have already been observed. Create a table named "new.tab" containing +those targets which have not previously been observed: + +.nf +tt> tdiffer targets.tab images.tab new.tab targetid targetid +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +tselect + +Type "help tables opt=sys" for a higher-level description of the 'tables' +package. +.endhelp diff --git a/pkg/utilities/nttools/doc/tdump.hlp b/pkg/utilities/nttools/doc/tdump.hlp new file mode 100644 index 00000000..ef146b58 --- /dev/null +++ b/pkg/utilities/nttools/doc/tdump.hlp @@ -0,0 +1,150 @@ +.help tdump Nov2000 tables +.nj +.ih +NAME +tdump -- Convert an STSDAS table to ASCII format. +.ih +USAGE +tdump table +.ih +DESCRIPTION +This task converts an STSDAS table to ASCII format. +The output does not include row numbers or column names; +use the 'tprint' task for more readable output. + +The two primary uses for 'tdump' are to allow editing that would be +difficult or impossible with 'tedit' (such as global substitutions) +and copying a table over a network to another computer. +For such purposes the table can be dumped to three separate files +(i.e., one containing column definitions, one for header parameters, +and one for table data), +the data may be edited, column data types changed, etc., +and then the 'tcreate' task can be used to reassemble the table +from the three ASCII files. +To prevent loss of information due to truncation, +floating point data are printed using g format with a wide field. +A character value with multiple words is printed with enclosing quotes +to make it clear that it is the value for a single column +and also for compatibility with 'tcreate'. + +All rows and columns of the table are dumped by default, +but ranges of rows and individual columns may be specified. + +The order of printing the data is as follows. +The first column of the first row is printed, +then the second column of the first row is printed, +then the third column of the first row, etc. +If any column contains arrays, +each element of the column array in the current row is printed +before moving on to the next column. +If the printed output is wider than a page (see 'pwidth'), +the output will consist of more than one line per row of the table. +After printing all columns in the first row, +the second row is printed in the same way. +Each row begins with a new line in the output text file. +Note that this can be different from 'tprint', +which prints all rows for those columns that will fit on a page, +then prints all rows for the next set of columns. +.ih +PARAMETERS +.ls table [file name] +The name of the STSDAS table to be dumped. +.le +.ls (cdfile = STDOUT) [file name] +If 'cdfile' is not null (i.e., it is not passed a value of "") +then the column definitions will be written +to an output file having the name passed to 'cdfile'. +(Note: A space is not null.) The column definitions consist of +the column name, data type ("R" for real, +"D" for double, "I" for integer, "B" for boolean, +or "CH*n" for character strings of length n), print format, and units. +For columns of arrays, +the array size is shown in square brackets appended to the data type. +.le +.ls (pfile = STDOUT) [file name] +If 'pfile' is not null (i.e., it is not passed a value of "") +then the header parameters will be written +to an output file with the name passed to 'pfile'. +This file will not be created +if there are no header parameters in the input file. +.le +.ls (datafile = STDOUT) [file name] +If 'datafile' is not null (i.e., it is not passed a value of "") then +the table data will be written +to an output file with the name passed to 'datafile'. +This file will not be created if the input table is empty. +.le +.ls (columns = "") [string] +The names of the columns to be printed. +A null value causes all columns to be printed. +A column template consists of a list +of either column names or column name templates that include wildcards. +Individual column names or templates are separated by commas or white space. +This list of column names can be placed in a list file and 'column' +will then be passed the file name preceded by a "@" character. +If the first non-white character in the column template +is the negation character (either "~" or "!") +the columns NOT named in the template will be printed. + +The 'tlcol' task (with the 'nlist' parameter set to 1) may be used +to generate a list of column names so there is no question about spelling. +This list may be edited to rearrange or delete columns. +.le +.ls (rows = "-") [string] +The range of rows to be printed. +The default of "-" means print all rows. +The first ten rows could be specified as 'rows="1-10"'. +To print the first ten rows and all rows from 900 through +the last (inclusive), use 'rows="1-10,900-"'. +Setting 'rows="1,3,7,23"' will print only those four rows. +It is not an error to specify rows larger than the largest row number; +they will simply be ignored. +Type "help xtools.ranges" for more information. +.le +.ls (pwidth = -1) [integer, min=-1, max=INDEF] +Width of the output for printing the table data. +The default value of -1 means that +checking the width should be disabled, +and each table row will be written to one line in the output file. + +If any column to be printed is wider than 'pwidth', +a warning message will be displayed, +and the data will overflow the page width. +The width of each character column is +increased by two to allow space for a pair of enclosing quotes, +which will be used if the value to be printed includes a blank or tab. +.le +.ih +EXAMPLES +1. Dump the table "junk.tab" to STDOUT: +.nf + + tt> tdump junk.tab cdfile=STDOUT pfile=STDOUT datafile=STDOUT + +.fi +2. Dump "junk.tab", but with the order of the columns rearranged: +.nf + + tt> tlcol junk.tab nlist=1 > colnames.lis + tt> edit colnames.lis + (Rearrange the column names and perhaps delete some of them.) + tt> tdump junk.tab columns=@colnames.lis +.fi + +3. Dump only the first 100 rows of the file "big.fits": + +.nf + tt> tdump big.fits rows="1-100" +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +tprint, tlcol, tcreate, ranges + +Type "help tables opt=sys" for a higher-level description of the 'tables' +package. +.endhelp diff --git a/pkg/utilities/nttools/doc/tedit.hlp b/pkg/utilities/nttools/doc/tedit.hlp new file mode 100644 index 00000000..80ff3381 --- /dev/null +++ b/pkg/utilities/nttools/doc/tedit.hlp @@ -0,0 +1,295 @@ +.help tedit Oct94 tables +.ih +NAME +tedit -- Edit a table. +.ih +USAGE +tedit table +.ih +DESCRIPTION +This task is a screen editor for STSDAS tables. You edit a table by +moving the cursor around the screen with the cursor keys and typing in +the new value of the table element. The screen scrolls both sideways +and up and down as you move the cursor, so all elements of the table +can be reached. Other editing commands are entered on the command +line. To switch from table editing mode to command line mode, you +press the EXIT key (usually Control-Z, however, you can change this). After +performing your command, the editor returns to table editing mode, +unless the command exits the editor. The most important commands in +command mode are `help', `exit', and `quit'. The `help' command +displays all the editing key bindings and the command line commands. +The `exit' command will get you out of the editor and automatically +save the edited table. The `quit' command will get you out of the +editor after asking you whether you want to save the table. By +default, the editor modifies a copy instead of the original table, so +if you quit without saving the table, the original table is still +there without any modifications. + +If you try to edit a table that does not exist, the editor will ask if +you want to create the table. If you answer "no", the editor will +exit. If you answer "yes", the editor will ask you for each column +name, type, unit, and print format. When you have finished entering +all the columns, press the return key instead of entering another +column name. The editor will create the table and put you in table +editing mode. + +To add a new, blank line to the end of a table, press the return key +while you are on the last line of the table. You can add blank lines +anywhere in the table with the `add row' command, which will be +described later. + +Some editing commands are entered from the command line in command +mode. To get to command line mode, press the exit key. This key is +bound to Control-Z by default. If you enter a blank line, the editor will +return to table editing mode. Some commands take arguments. They can +be included when the command is entered, or if they are omitted, the +editor will prompt you for their values. If the argument has embedded +blanks, the argument should be enclosed in quotes if passed on the +command line. No quotes should be used if the argument is entered +interactively. When the editor interactively prompts you for a command +argument it will also display a default value for the argument. +Pressing the return key gets the default value. Some command names are +two words long, for example, "add row". Usually the second word is +optional and modifies the meaning of the first, for example "copy +append". If the second word is not optional and you omit it, the +editor will prompt you for it. All command names can be abbreviated to +one or more letters. If the command name is two words long, both words +can be abbreviated to one or more letters. + +The following is a list of the available commands: + +.ls add column +Add a new column to the table with the specified name and data type. +.le +.ls add row +Add new, blank rows after row number . The legal range of is +0 to the number of rows in the table. The number of blank rows to add is +. +.le +.ls copy +Copy the rows between and into the paste buffer. The +current contents of the paste buffer are destroyed before the copy. +The table is not modified by this command. The contents of the paste +buffer can be put back into the table by the 'insert' command. +.le +.ls copy append +Copy the rows between and into the paste buffer. The +current contents of the paste buffer are preserved and the new rows +are inserted after them. +.le +.ls delete +Delete the rows between and . The deleted rows are placed +into the paste buffer and the current contents of the paste buffer are +destroyed. +.le +.ls delete append +Delete the rows between and . The deleted rows are appended +to the paste buffer. +.le +.ls exit +Exit the table editor, saving any changes made to the table. +.le +.ls find +Find the next row in the table which makes true and move +the cursor to that row. The expression has the same syntax as an +expression in a Fortran if statement. The variables in the expression +are column names. For more information on the syntax of the +expression, read the help for 'tselect'. The direction of the search depends +upon previous 'find' commands. By default the search direction is forward; +however, if a "find backwards" command has been executed previously, +searches will be done in a backwards direction until a "find forward" +command is executed. +.le +.ls find forward +Find the next row in the table which makes true and move the +cursor to that row. The search is done in the forwards direction. +.le +.ls find backwards +Find the next row in the table which makes true and move the +cursor to that row. The search is done in the backwards direction. +.le +.ls goto +Move the cursor to and . +.le +.ls help +Display online help information for the table editor. The help includes +a brief description of each command line command and the key bindings +for table editing commands. +.le +.ls insert +Insert the contents of the paste buffer after row number . The +contents of the paste buffer are not changed. +.le +.ls lower +Convert to lower case. Only string columns can be converted. +.le +.ls next +Repeat the previous find command, using the same expression and search +direction that was used with it. +.le +.ls next forward +Repeat the previous find command, changing the search direction to +forwards. +.le +.ls next backwards +Repeat the previous find command, changing the search direction to +backwards. +.le +.ls quit +Exit the table editor. If the table has been changed, the table editor +will ask you whether to save it before exiting. +.le +.ls set +Set a column equal to an expression. If the column is a string column, +the expression must be a constant. If the column is numeric, the +expression can either be a constant or a Fortran-like expression. For +the exact syntax of the expression, see the help file for tcalc. +.le +.ls substitute +Search for and replace text patterns in a column. The syntax for the +target and replacement pattern strings largely follows that used in +the substitute command by the Unix text editors `ed' and `ex'. The +pattern consists of a sequence of ordinary characters, which match +themselves, and meta-characters, which match a set of characters. A +meta-character can be matched as if it were an ordinary character by +preceding it with the escape character, `\'. For example, the escape +character itself is indicated in a pattern by `\\'. The meta-characters +which can be used in the target pattern are: + +.nf +beginning of string ^ end of string $ +white space # escape character \ +ignore case { end ignore case } +begin character class [ end character class ] +not, in char class ^ range, in char class - +one character ? zero or more occurrences * +begin tagged string \( end tagged string \) +.fi + +A set of characters is indicated in the target string by the character +class construct. For example, punctuation could be indicated by +`[,;.!]'. A range of characters contiguous in the underlying +character set can be abbreviated by the range construct. For example, +`[a-z]' matches any lower case character. The complement of a +character set is indicated by making `^' the first character in a +class. For example, `[^0-9]' matches any non-digit. Repetition of a +character or character class is indicated by the following it with the +`*' meta-character. Thus, zero or more occurrences of a lower case +character is indicated by `[a-z]*'. The tagged string meta-characters +have no effect on the match, they only serve to identify portions of +the matched string for the replacement pattern. The meta-characters +which are used in the replacement pattern are the following: + +.nf +entire string & tagged string \n +capitalize \u upper case \U +lower case \L end case conversion \e \E +.fi + +The ditto meta-character, `&', indicates that the entire portion of the +string that was matched by the target pattern. The tag meta-character +indicates that the n-th tagged string. For example, `\1' indicates +the first tagged string and `\2' the second. The remaining +meta-characters affect the case of the output string. The +capitalization meta-character only affects the immediately following +meta-character, but the upper and lower case meta-characters must be +turned off explicitly with `\e' or `\E'. +.le +.ls upper +Convert to upper case. Only string columns can be converted. +.le + +The bindings to the table editing keys are read from the edcap file. +This is the same file which is used to define the key bindings for the +parameter editor and history editor. The edcap file defines key +bindings which resemble those of commonly used text editors. Three +edcap files are distributed with IRAF. They define key bindings which +resemble EDT, Emacs, and vi. These edcap files are located in the 'dev$' +directory and have the extension '.ed'. The appropriate file is chosen +according to the value of the environment variable 'EDITOR'. If you +want to customize the key bindings of the table editor, copy the +appropriate edcap file from the 'dev$' directory to your 'home$' directory +and edit the second column of the file. The table editor searches your +home directory first for the edcap file and if it does not find it, +then it searches the 'dev$' directory. + +The table editor also uses the termcap file to determine the screen +size and the escape sequences used to modify the screen. There are +entries in the termcap file for almost all terminal types. The proper +entry is selected according to the environment variable 'TERMINAL'. To +change your terminal type or the screen size, use the IRAF 'stty' +command. + +The 'tread' task can also be used to view a file in readonly mode. +.ih +PARAMETERS +.ls table [string] +The name of the table to be edited. The editor checks for the +existence of the table and its access mode before editing. If the +table does not exist, the editor will ask whether you want to create +a new table. If you do not have write access to a table you can only +edit it by setting 'rdonly=yes'. +.le +.ls (columns = "") [string] +The names of the columns to be edited. +A null or blank string means edit all columns. +A column template consists of a list of either +column names or column patterns containing the usual pattern matching +meta-characters. The names or patterns are separated by commas or +white space. The list can be placed in a file and the name of the +file preceded by an "@" given in its place. +If the first character in the column template is a bang (!), +all columns NOT named will be displayed. + +The 'tlcol' task (with the 'nlist' parameter set to 1) may be used to generate +a list of +column names so there is no question about spelling. This list may be +edited to rearrange or delete the names, and then the list +file is given preceded by an '@' sign, for example: + +.nf +tt> tedit junk columns=@colnames.lis +.fi +.le +.ls (silent = no) [boolean] +Turn off the bell indicating warning messages? +.le +.ls (rdonly = no) [boolean] +View a table without modifying it? This parameter prevents you from +executing +any command that would modify the file. +.le +.ls (inplace = no) [boolean] +Replace existing table? If 'rdonly' is +set to "yes" the table is always edited in place. +.le +.ih +EXAMPLES +1. Make a copy of the table 'm12b.tab' (if it exists) and edit the copy. +If the table does not exist +then a temporary table is created, and you will be prompted for the +name of the first column to be created. In either case, if you +exit (rather than quitting) the temporary table will be renamed to +'m12b.tab'. + +.nf +tt> tedit m12b +.fi + +2. Display the columns 'SHARP' and 'ROUND' in an existing table. Rows may +be added or deleted, and columns may be added. + +.nf +tt> tedit m12b columns="SHARP,ROUND" +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +tread, tprint, tselect, stty + +Type "help tables opt=sys" for a description of the 'tables' package. +.endhelp diff --git a/pkg/utilities/nttools/doc/texpand.hlp b/pkg/utilities/nttools/doc/texpand.hlp new file mode 100644 index 00000000..52fd03e6 --- /dev/null +++ b/pkg/utilities/nttools/doc/texpand.hlp @@ -0,0 +1,159 @@ +.help texpand Dec90 tables +.ih +NAME +texpand -- Expand table rows according to a set of rules. +.ih +USAGE +texpand input output rbase +.ih +DESCRIPTION +This task uses a set of rules to convert each row in the input table +into one or more rows in the output table. Except for these +conversions, the output table is identical to the input table. The set +of rules is contained in a text file specified by the 'rbase' parameter. +Each rule has two parts, the target and +the action. + +Rules are applied in the following ways. The task reads a row +from the input table. It then looks at the target part of each rule in +the rules file in the order that they were placed in the file. If the +input row does not match the target part of any rule, it is written to +the output table without being changed. +Otherwise, the first rule whose target matches the +input row is used to convert the input row. The columns and values +contained in the action part of the rule are used to modify the +input row to produce a new output row. After the new row is produced, the set +of rules is searched again to see if any of the rules can be applied +to the new row. This process continues until no further matches can be +found, at which point the new rows are written to the output table. + +For example, suppose the following rules are contained in the rules +file: +.nf + +SEX = M && NAME = ANY => NAME = Tom || NAME = Dick || NAME = Harry; +SEX = F && NAME = ANY => NAME = Mary || NAME = Jane; +SEX = X => SEX = M || SEX = F; + +.fi +And suppose the input table contains the following information: +.nf + +NAME SEX TITLE +ANY X Astronomer + +.fi +The first two rules impose two conditions, the first on the value of +the 'SEX' column and the second on the value of the 'NAME' column. While +the value of the 'NAME' column matches the conditions in the first two +rules, the value of 'SEX' does not. The third rule only imposes one +condition, which does match the row in the input table. Thus the third +rule of the rule file is applied to the input table and the following +intermediate result is produced: + +.nf + +NAME SEX TITLE +ANY M Astronomer +ANY F Astronomer + +.fi +The rules file is searched again, and now the first rule matches the +first row and the second rule matches the second row. So the following +result is produced when these two rules are applied: +.nf + +NAME SEX TITLE +Tom M Astronomer +Dick M Astronomer +Harry M Astronomer +Mary F Astronomer +Jane F Astronomer + +.fi +The rules file is searched again, and because no matches are found, +the results are written to the output table. + +The above example shows some of the syntax of the rules file. The +target and action parts of a rule are separated by the symbol "=>" and +the entire rule is terminated by a semicolon. Unlike the above +example, a rule need not be contained on a single line; it can be +split among as many lines as desired, since the semicolon marks the +end of the rule. The amount of white space used is also optional, +symbols and identifiers may be run together or separated by blanks, +tabs, and blank lines. Comments may be placed on any line; they begin +with the "#" character and run to the end of the line. The different +conditions in the target part of a rule are separated by the symbol +"&&". Each condition consists of a column name and a column value +separated by an equals sign. The different results in the action part +of a rule are separated by the symbol "||". Each result consists of a +set of column names and values separated by equals signs. If there is +more than one column name and value in the result, the different +name/value pairs are separated by "&&" symbols. An example of a rule +with all these syntax elements is: +.nf + +TARGET = ANY && OBSERVER = ANY => # Two conditions + TARGET=M31 && OBSERVER = HUBBLE || # First result + TARGET='OMEGA CENT' && OBSERVER = STRUVE ; # Second result + +.fi +Notice that in the above example that an identifier containing a blank +can be used if the identifier is enclosed in quotes. Double quotes +could also have been used. Case is significant in an identifier. If a +syntax error is detected in a rules file or a column is named which +does occur in the input table, the task is terminated with a syntax +error. The error message contains the line and line number where the +error was detected and a brief message indicating the type of error. + +This task can also be used to process more than one table by using file +name templates for the 'input' and 'output' parameters instead of file names. +Because processing each table takes a relatively long time, the +parameter 'verbose' can be set to "yes" so that the name of each table +will be displayed when it is processed. +.ih +PARAMETERS +.ls input [file name template] +Name of a table, or list of tables, used as input to the task +.le +.ls output [file name template] +Name of a table, or list of tables, to be produced as output to the task. The +number of input and output tables must be equal. +.le +.ls rbase [file name] +The file containing the rules used to expand the tables. +.le +.ls (debug = "") [file name] +The file containing the debugging output. If the file name is blank or null, +no debugging output is produced. When creating a set of rules, the output +produced by this task is not always what you expect. Turning on the debugging +output prints all the intermediate rule expansions to the designated file +as an aid in debugging the set of rules. +.le +.ls (verbose = no) [boolean] +Display the names of the input and output tables on the terminal screen (i.e., +STDOUT) after each file is processed? +.le +.ih +EXAMPLES +1. Expand the table 'example' into 'example_2' using the rules in +'xrules.txt': + +.nf +tt> texpand example.tab example_2.tab xrules.txt +.fi + +2. Expand a set of fos tables using the rules in 'fosrules.txt': + +.nf +tt> texpand y*.tab y*%%_2%.tab fosrules.txt verbose+ +.fi +.ih +BUGS +The task cannot expand tables with boolean columns. +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +.endhelp diff --git a/pkg/utilities/nttools/doc/thedit.hlp b/pkg/utilities/nttools/doc/thedit.hlp new file mode 100644 index 00000000..9a3b2a2f --- /dev/null +++ b/pkg/utilities/nttools/doc/thedit.hlp @@ -0,0 +1,208 @@ +.help thedit Feb2002 ttools +.nj +.ih +NAME +thedit -- Edit or view keyword values in tables. +.ih +USAGE +thedit table keywords value +.ih +DESCRIPTION +This table header editor can be used to add, delete, edit, +or just print the values of table header keywords. + +Although this task was based on 'hedit', +there are significant differences. +The 'add', 'verify', and 'update' parameters of 'hedit' +are not included in 'thedit'. +If a specified keyword does not already exist, +then it will be added +(equivalent to add=yes in 'hedit'). +If a keyword does not exist, +and the value expression is ".", +a warning will be printed +('hedit' is silent in this case). + +Such parameters as the number of rows or columns in the table +are stored differently in FITS, STSDAS, and text tables. +The following special "keywords" can be used +to reference such information regardless of table type. +These may be used in the 'keywords' parameter when value=".", +or they can be used in the 'value' parameter as part of an expression. + +.nf + i_table string table name (may include extension ID) + i_file string name of the file containing the table + i_ctime string file modification (or creation) time + i_nrows int number of rows in the table + i_ncols int number of columns in the table + i_npar int number of keywords in the table header + i_type string table type +.fi + +'thedit' supports two of the special operands +that are available in 'hedit': "$" and "$I". +When 'value' is an expression, +"$" gives the value of the current keyword. +"$I" is equivalent to "i_table", +the name of the current table. +"$I" can be used as a keyword or as part of an expression. +.ih +PARAMETERS +.ls table [file name template] +A list of tables for which keywords are to be edited or printed. +If 'value' is ".", each table will be opened read-only; +otherwise, each table will be opened read-write. +.le +.ls keywords [string] +One or more keywords, separated by commas and/or blanks, +which are to be added, modified, or printed. +If the value expression (see 'value') is not ".", +any keyword in 'keywords' that is not already present +will be added to the header. + +Wildcards are supported; however, +the "@filename" syntax is not supported. +Do not use wildcard or other special characters +if a keyword is to be added to the header. +.le +.ls value = "." [string] +This is the value to be assigned to each keyword in 'keywords'. +The special value "." means that +the keywords should be printed rather than edited, +and in this case the table will be opened read-only. +If 'value' is not equal to ".", +the same value will be assigned to all the keywords +matching the template 'keywords'. + +In order to set a keyword value to "." or ",", +specify the value as "\." or "\," respectively. +(Note that if given on the command line, +the quotes are required in this case.) Requiring "," to be escaped +was added as protection against accidentally typing "," instead of ".". + +As with 'hedit', +a general expression may be given for 'value' +by enclosing the expression in parentheses. +The expression may include constants and/or keyword names; +it will be evaluated and then assigned to each keyword in 'keywords'. + +Note that if delete = yes, then 'value' will be ignored. +.le +.ls (delete = no) [bool] +If delete = yes, the specified keywords will be deleted. +All the keywords listed in 'keywords' will be deleted, +for each table in 'table'. +.le +.ls (show = yes) [bool] +Print a record of each edit operation? +.le +.ih +EXAMPLES +1. Display all the header keywords (except blank) in "example.tab". + +.nf + tt> thedit example.tab * . +.fi + +2. Display only the special keywords for "timetag.fits[events]". + +.nf + tt> thedit timetag.fits[events] i_* . + + timetag.fits[events],i_table = timetag.fits[events] + timetag.fits[events],i_file = timetag.fits + timetag.fits[events],i_ctime = "Wed 12:07:58 31-May-2000" + timetag.fits[events],i_nrows = 337824 + timetag.fits[events],i_ncols = 6 + timetag.fits[events],i_npar = 58 + timetag.fits[events],i_type = "fits, binary" +.fi + +3. Print all HISTORY keywords in "example.txt". + +.nf + tt> thedit example.txt history . +.fi + +4. Add a new HISTORY keyword to "example.tab". + +.nf + tt> thedit example.tab history \ + "('file name is ' // i_file) // '; number of rows = ' // str (i_nrows)" +.fi + +5. Increment the value of COUNT. + +.nf + tt> thedit example.tab count "($ + 1)" +.fi + +6. Delete all HISTORY and COMMENT keywords in "example.fits[1]". + +.nf + tt> thedit example.fits history,comment delete+ +.fi + +7. Evaluate a simple expression +and assign the result to keyword WAVELEN. +Keywords TCRVL1, TCDLT1, and NELEM +are assumed to be already present in the header. + +.nf + tt> thedit example.fits wavelen "(tcrvl1 + tcdlt1 * nelem/2.)" +.fi + +8. A keyword can be renamed by using a two-step process, +first creating a new keyword with the old value, and then +deleting the old keyword. +Note that while this procedure does copy the value, +the comment will be lost. +(The "k" instruction in 'tupar' can also be used to rename a keyword.) + +.nf + tt> thedit example.tab newkey "(oldkey)" + tt> thedit example.tab oldkey delete+ +.fi + +9. The primary header or an image extension of a FITS file +can also be opened as a table in order to access the keywords. + +.nf + tt> thedit o47s01kdm_raw.fits[0] rootname . + tt> thedit o47s01kdm_flt.fits[1] bunit "COUNTS/S" +.fi + +10. This could have been a big mistake. + +.nf + tt> thedit abc.fits[1] * , + + ERROR: In order to set a keyword value to ',' you must use value='\,' +.fi +.ih +BUGS +Expressions are evaluated using EVEXPR, +which does not support double precision. + +Header lines with keyword = ' ' cannot be displayed. + +The 'value' parameter is of type string, +and 'thedit' interprets the value +to determine what data type to use +when writing the value to the table. +This can fail when a value appears to be a number +but really should be treated as a string. +For example, a date and time could be written as "19940531:11515000". +'thedit' would interpret this as hours and minutes (HH:MMss) +and convert the value to 1994053. + 11515000./60. +A workaround for this case is to use 'tupar' instead of 'thedit'; +use the "pt" instruction, meaning put a keyword of type text. +.ih +REFERENCES +This task was written by Phil Hodge, +based on the 'hedit' task. +.ih +SEE ALSO +hedit, tupar +.endhelp diff --git a/pkg/utilities/nttools/doc/thistogram.hlp b/pkg/utilities/nttools/doc/thistogram.hlp new file mode 100644 index 00000000..f8c0003e --- /dev/null +++ b/pkg/utilities/nttools/doc/thistogram.hlp @@ -0,0 +1,152 @@ +.help thistogram Mar94 tables +.nj +.ih +NAME +thistogram -- Make a histogram of a table column. +.ih +USAGE +thistogram intable outtable column +.ih +DESCRIPTION +This task generates a histogram of the values in a column. +The histogram may be written to STDOUT or to a table. +If there is more than one table in the input list then a separate histogram +is generated for each table. +If there is more than one input table and the histogram of the values +in all the tables combined is needed, then the tables should first be +merged using the 'tmerge' task with the 'option' parameter set to "append". + +If x1 and x2 are the lower and upper limits of a particular bin, +a value X will be included in the bin if x1 <= X < x2. +Note that this also applies to the upper limit ('highval') of the last bin. + +There are six interrelated parameters +having to do with the number of bins, bin width, and bin locations. +Any number of these may be specified as long as the values are consistent. +As a minimum, only one value is required, either 'nbins' or 'dx'. +The task computes what it doesn't have +based on the parameters that were specified, +or based on the minimum and maximum data values +in the table column if necessary. +If the minimum (maximum) column data value is used, +that value will normally be reduced (increased) a bit +before being used as 'lowval' ('highval') +to ensure that the value is included in the range. +The relationships between the parameters is as follows: + +.nf + dx = (highval - lowval) / nbins + dx = (chigh - clow) / (nbins - 1) + clow = lowval + dx / 2 + chigh = highval - dx / 2 +.fi +.ih +PARAMETERS +.ls intable [file name template] +A list of input tables. +A histogram will be generated for one column in the table; +the same column name is used for each table in the list. +The name of the column is specified using the 'column' parameter, +.le +.ls outtable = STDOUT [file name template] +Output tables or STDOUT. +If the value of this parameter is "STDOUT" +then the histogram will be written to the standard output +preceded by a header line (beginning with "#") +that gives the number of rows included in the histogram +and the name of the table. +If 'outtable' is passed a file name, +then the number of names must match the number of file names in 'intable', +and the histogram of each input table +will be written to an output table of the specified name. +.le +.ls column [string] +Column name in input tables that will be used to generate the histogram. +Only the values in the column with this name will be used. +The same column name is used for each input table. +.le +.ls (nbins = 100) [integer, min=1] +Number of bins in the histogram. +Normally either 'nbins' or 'dx' (or both) must be given. +You could also give both 'lowval' and 'clow', +or both 'chigh' and 'highval', +since the bin width can be computed from these. +.le +.ls (lowval = INDEF) [real] +Lower limit for histogram. +Values below 'lowval' will not be used in generating the histogram. +If 'lowval = INDEF', then the minimum value in the table column will be used. +.le +.ls (highval = INDEF) [real] +Upper limit for histogram. +Values equal to or greater than 'highval' will not be used in generating +the histogram. +If 'highval = INDEF', then the maximum value in the table column will be used. +.le +.ls (dx = INDEF) [real] +Bin width. +.le +.ls (clow = INDEF) [real] +Value at the center of the first bin. +.le +.ls (chigh = INDEF) [real] +Value at the center of the last bin. +.le +.ls (rows = -) [string] +Range of rows to use for generating the histogram. +The default "-" means that all rows are used. +(Type "help xtools.ranges" for more information.) +.le +.ls (outcolx = value) [string] +Column name for bin centers. +If the output is written to a table rather than to STDOUT, then 'outcolx' +is the column name containing the bin centers. +This column will be double precision. +.le +.ls (outcoly = counts) [string] +Column name for histogram values. +If the output is written to a table then 'outcoly' is the column name +containing the number of counts in the bin. +This column will be of integer data type. +.le +.ih +EXAMPLES +1. Generate a histogram of the values in the 'flux' column in every table +whose name begins with "hr"; put all the histograms in the ASCII file +'hist.lis'. + +.nf + tt> thistogram hr*.tab STDOUT flux > hist.lis +.fi + +2. Generate the same histograms as in the previous example, but put the +results in tables rather than displaying them on the terminal screen. +One output file is produced for each input table; for example, +the histogram for an input table 'hr465.tab' would be put in 'hr465h.tab'. + +.nf + tt> thistogram hr*.tab hr*%%h%.tab flux +.fi + +3. Plot the histogram of column 'V' in 'bs.tab': + +.nf + tt> thistogram bs STDOUT V | sgraph (crvstyle="pseudohist") +.fi + +4. Plot the same histogram as in the previous example, +but set the spacing between bins to be 0.1. + +.nf + tt> thistogram bs STDOUT V nbins=INDEF dx=0.1 | \\ + >>> sgraph (crvstyle="pseudohist") +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +ranges +.endhelp diff --git a/pkg/utilities/nttools/doc/thselect.hlp b/pkg/utilities/nttools/doc/thselect.hlp new file mode 100644 index 00000000..7cabe98d --- /dev/null +++ b/pkg/utilities/nttools/doc/thselect.hlp @@ -0,0 +1,90 @@ +.help thselect Jul2000 ttools +.nj +.ih +NAME +thselect -- Print table keyword values. +.ih +USAGE +thselect table keywords expr +.ih +DESCRIPTION +This task was based on 'hselect', +and it behaves in a very similar manner, +except that it works on tables rather than images. + +Keyword values will be printed to the standard output, +one line per input table, +with the values separated by tabs. +String values that contain whitespace will be enclosed in quotes. +.ih +PARAMETERS +.ls table [file name template] +A list of tables for which keywords are to be printed. +These will be opened read-only and will not be modified. +.le +.ls keywords [string] +One or more keywords, separated by commas and/or blanks. +The special keywords such as "i_table" +that are supported by 'thedit' can also be used with 'thselect'. + +For each input table, +the values of these keywords in the current input table will be printed, +if 'expr' is a true expression for the current table. +Any keyword that is not found will be silently ignored. + +Wildcards are supported; however, +the "@filename" syntax is not supported. +.le +.ls expr = "yes" [string] +This is a boolean expression +to be evaluated for each table in the list. +The default value may be used to unconditionally print keyword values. + +The expression may include constants and/or keyword names. +.le +.ih +EXAMPLES +1. Compare 'thselect' with 'thedit' for displaying a single keyword value. + +.nf + tt> thselect timetag.fits[events,7] rootname yes + + O57P03030 + + tt> thedit timetag.fits[events,7] rootname . + + timetag.fits[events,7],ROOTNAME = O57P03030 / rootname of the obser + vation set +.fi + +2. Compare i_file with i_table for a FITS table +($I and i_table are equivalent). + +.nf + tt> thselect timetag.fits[events,7] i_file,i_table yes + + timetag.fits timetag.fits[EVENTS,7] +.fi + +3. Find all FITS files with DETECTOR = 'CCD' in the primary header. +Since the primary header of a FITS file can be opened +either as an image or as a table, +either 'hselect' or 'thselect' could be used for this example. + +.nf + tt> thselect *.fits[0] $I "detector == 'CCD'" + + h1v11148o_1dx.fits[0] + h4s13500o_1dx.fits[0] + i1c1615po_1dx.fits[0] +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge, +based on 'hselect'. +.ih +SEE ALSO +hselect, thedit +.endhelp diff --git a/pkg/utilities/nttools/doc/tinfo.hlp b/pkg/utilities/nttools/doc/tinfo.hlp new file mode 100644 index 00000000..4c712fbe --- /dev/null +++ b/pkg/utilities/nttools/doc/tinfo.hlp @@ -0,0 +1,125 @@ +.help tinfo Jun1999 tables +.nj +.ih +NAME +tinfo -- Display information about a table. +.ih +USAGE +tinfo table +.ih +DESCRIPTION +This task is used to display information about a table. +This information includes +such things as the number of rows and columns. +The output is written to STDOUT by default. +The first line of output for each table in the input list is the table +name preceded by a # sign. +The values for the last table in the list are also put into parameters +for the 'tinfo' task so that other tasks in a script may use the values. + +The parameters 'nrows', 'ncols', 'npar', 'rowlen', 'rowused', 'allrows', +'maxpar', 'maxcols', 'tbltype', 'subtype' and 'tblversion' +are output parameters. +Since they are set rather than read by 'tinfo', +any value assigned by the user will be overwritten. +.ih +PARAMETERS +.ls table [file name template] +A list of tables for which size information is to be produced. +.le +.ls (ttout = yes) [boolean] +Display information on the terminal screen as it is being placed into +parameters? Setting 'ttout = no' will cause information to be placed +only into task parameters. +.le +.ls (nrows) [integer] +The number of rows written to the table. +This and all subsequent parameters are output task parameters; +that is, they are written by the 'tinfo' task. +.le +.ls (ncols) [integer] +The number of columns in the table. +.le +.ls (npar) [integer] +The number of header parameters in the table. +.le +.ls (rowlen) [real] +For a row-ordered table, +'rowlen' is the amount of space allocated for each row in the table file. +The unit of 'rowlen' is the size of a single-precision real number. + +This is only relevant for row-ordered STSDAS format tables. +.le +.ls (rowused) [real] +'rowused' is the amount of the row length ('rowlen') +that has actually been used +by the columns that have been defined, +in units of the size of a real number. +For example, if a table contains three columns +with data types integer, real and double precision, +then 'rowused' would be four. +If the table contains only one column of data type short, +then 'rowused' would be 0.5. + +This is only relevant for row-ordered STSDAS format tables. +.le +.ls (allrows) [integer] +The number of allocated rows. +This is relevant only for column-ordered STSDAS format tables. +.le +.ls (maxpar) [integer] +The space allocated for header parameters. +.le +.ls (maxcols) [integer] +The space allocated for column descriptors. +.le +.ls (tbltype) [string] +The table type, currently either "stsdas", "fits" or "text". +"stsdas" is a machine dependent binary format, +the default .tab format. +"fits" means that the table is a TABLE or BINTABLE extension +in a FITS file. +"text" is an ASCII file in tabular format. +See also 'subtype'. +.le +.ls (subtype) [string] +For FITS tables the subtype can be either +"ascii" (a TABLE extension) or "binary" (a BINTABLE extension). +For text tables the subtype can be either +"simple" or "explicit column definitions". +The latter subtype means there are column definition lines in the file, +in the format: "#c column_name datatype print_format units". +A simple text table has column names c1, c2, etc., and no units. +For STSDAS format tables +the subtype will be either "row ordered" or "column ordered", +which indicates the way the elements are stored in the table file. +.le +.ls (tblversion) [integer] +The version code is an integer that identifies the version of +the tables package that created or last modified the table. +For STSDAS tables, the version code is stored in the table file; +for other formats this parameter is just +the current tables version code number. +This number is zero for 'stsdas' and 'tables' versions 1.2.3 and earlier, +the number is one for versions 1.3 through 1.3.3, +the number is two beginning 1995 March 6, +and the number is three beginning 1998 April 14. +.le +.ih +EXAMPLES +1. Get size information about the file 'm87pol.tab', +but do not print the information to STDOUT, +just put the values into parameters. + +.nf + tt> tinfo m87pol ttout=no +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +tlcol +.endhelp diff --git a/pkg/utilities/nttools/doc/tintegrate.hlp b/pkg/utilities/nttools/doc/tintegrate.hlp new file mode 100644 index 00000000..9ea9f081 --- /dev/null +++ b/pkg/utilities/nttools/doc/tintegrate.hlp @@ -0,0 +1,97 @@ +.help tintegrate Jan96 tables +.ih +NAME +tintegrate -- Calculate the integral of one table column with +respect to another. +.ih +USAGE +tintegrate table integrand independent +.ih +DESCRIPTION +The program evaluates the integral of the column name passed to +'integrand' with respect to +the column passed to 'independent' using the simple trapezoidal rule. +The column passed to 'independent' must have values +sorted in ascending order. +INDEF values in either column are ignored, and there must be at least +two good points common to both columns. +The result is written to STDOUT and also recorded as a task parameter +'integral'. + +If the 'independent' parameter is null or blank, +the values in the 'integrand' column will simply be added up. +Note that this is not exactly the same as the trapezoidal rule +for integrating over row number. (A row number column +can be created using 'tcalc'.) When integrating over a column +that contains the row numbers, +'tintegrate' adds together all rows except the first and last +with unit weight; +the first and last are included with a weight of one half. +.ih +PARAMETERS +.ls table [file name] +The input table. +.le +.ls integrand [string] +Column name whose contents will be the integrand. +.le +.ls independent [string] +Column name whose contents will be the independent variable; +the values in this column must be increasing with row number. +If 'independent' is null, +then 'tintegrate' will just sum the values in the 'integrand' column. +.le +.ls (integral) [real] +The result returned by the task. +This is an output parameter; it is not directly changed by the user. +.le +.ls (ptsused) [integer] +The number of points used in calculating the integral. +This is also an output parameter and is not specified by the user. +.le +.ih +EXAMPLES +1. Calculate the integral of flux over wavelength, +printing the result to STDOUT +(and also storing it in the 'integral' parameter). + +.nf +tt> tintegrate intab flux lambda + integral= 0.8752311663155779 using 401 points +.fi + +2. Sum the values of flux, rather than integrating over wavelength. + +.nf +tt> tintegrate intab flux "" + integral= 30.32557976245881 using 401 points + +as an alternative: + +tt> tstat intab flux +# civ flux +# nrows mean stddev median min max + 401 0.07562488719 0.171107 -0.0381 -0.72729 0.22527 +tt> =0.07562488719 * 401 +30.32557976319 + +.fi + +3. Integrate the flux over row number. +This is the same as summing the flux except for the first and last rows. + +.nf +tt> tcalc intab row rownum datatype="real" colfmt="%8.1f" +tt> tintegrate intab flux row + integral= 30.34466478228569 using 401 points +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by David Giaretta. +.ih +SEE ALSO +tcalc +tstat +.endhelp diff --git a/pkg/utilities/nttools/doc/tjoin.hlp b/pkg/utilities/nttools/doc/tjoin.hlp new file mode 100644 index 00000000..45d2dcc2 --- /dev/null +++ b/pkg/utilities/nttools/doc/tjoin.hlp @@ -0,0 +1,120 @@ +.help tjoin Apr99 tables +.ih +NAME +tjoin -- Combine two tables based on equal values in common columns +.ih +USAGE +tjoin intable1 intable2 outtable column1 column2 +.ih +DESCRIPTION +This task combines two tables into a new table on the basis of one or +more common columns. Two rows from the input tables are combined to +form a row of the output table whenever the values in the common +columns are equal. If a row in one of the input tables matches several +rows in the other input table, all combinations of the rows are placed +in the output table. Null table elements are never matched. Tables +can be joined on row number as well as on column by setting the column +name to "row". + +This task has three hidden parameters, 'extrarows', 'tolerance', and +'casesens'. By default, if a row in one of the input tables does not +match any row in the other input table, it is not placed in the output +table. However, if the parameter 'extrarows' is set to 'first', rows +in the first table that are unmatched are added to the output table +and if 'extrarows' is set to 'both', unmatched rows from both input +tables are added to the output table. + +The task parameter 'tolerance' is a comma separated list of +values. The number of values should either equal to the number of join +columns or one. If only one value is supplied and there are more than +one join column, the value is used for all columns. If the difference +between two column values is less than or equal to the corresponding +value of 'tolerance', the values are considered equal and their +respective rows are placed in the output table. + +If 'casesens = no', the case of a string is ignored when testing for +equality. 'tolerance' must be set to zero when comparing string or +boolean columns. + +If a value of 'tolerance' is nonzero, the output table will contain the +corresponding join columns from both tables. If a value of +'tolerance' is zero, the output table will contain a single join column, +as both values are identical. If a column name in the first input +table is the same as a column name in the second input table, this +task tries to create a unique name by appending "_1" to the first name +and "_2" to the second name. If the task cannot create a unique name +in this way, it stops with an error. +.ih +PARAMETERS +.ls intable1 [file name] +First input table. +.le +.ls intable2 [file name] +Second input table. +.le +.ls outtable [file name] +Output table. This is the join of the two input tables. +.le +.ls column1 [string] +Names of the common columns in the first table. If there is more than +one column name, the names should be separated by commas. If a column +name is "row", the join is done on row number instead of the value of +a column. This only works if there is not column named "row" in the +table. +.le +.ls column2 [string] +Comma separated list of names of the common columns in the second +table. The number of names must match the number of names in column1. +The name may be "row", in which case the join is done on row number. +.le +.ls (extrarows = "neither") [string, allowed values: neither|first|both] +This parameter controls whether unmatched rows are added to the output +table. If it is set to 'neither', unmatched rows are not added. If it +is set to 'first', unmatched rows from the first table are added. If +it is set to 'both', unmatched rows from both tables are added. When +unmatched rows are added to the output table columns in the output +table derived from the other table have their values left undefined. +.le +.ls (tolerance = "0.0") [string] +Tolerance used in testing for equality between common columns. The +values must be greater than or equal to zero. If there is more than +one common column, this parameter may be a comma separated list of +values. In this case, the number of tolerance values must equal the +number of common columns or be one. If there is only one tolerance +value, the same value is used for all columns. +.le +.ls (casesens = yes) [boolean] +Is case important in testing equality of strings? +If set to "yes", the test for equality is case sensitive. +.le +.ih +EXAMPLES +1. Combine a table of star positions and a table of star magnitudes to create +a star catalog. The star name is not case sensitive: + +.nf +tt> tjoin starpos.tab starmag.tab starcat.tab name name case- +.fi + +2. Create a table of all spectral lines that match a set of reference +wavelengths within 10 angstroms: + +.nf +tt> tjoin spectrum.tab reference.tab lines.tab WAVE WAVE tol=10. +.fi + +3. Combine a phone list with an address list where the name is stored +in two columns, "last" and "first". + +.nf +tt> tjoin phone.tab address.tab output.tab LAST,FIRST LAST,FIRST +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +tselect, tproject, tproduct +.endhelp diff --git a/pkg/utilities/nttools/doc/tlcol.hlp b/pkg/utilities/nttools/doc/tlcol.hlp new file mode 100644 index 00000000..c9bd9c94 --- /dev/null +++ b/pkg/utilities/nttools/doc/tlcol.hlp @@ -0,0 +1,75 @@ +.help tlcol May2000 tables +.nj +.ih +NAME +tlcol -- Display column information. +.ih +USAGE +tlcol table +.ih +DESCRIPTION +This task is used to list column information for a table. The output is +written to STDOUT, which may be redirected to a file. There will be one line +of output for each column in the table, and each output line may contain the +column name, data type, print format, and units. +The first line of output for each table in the input list is the table +name preceded by a # sign. + +The output from this task may be used as input to various tasks such +as 'tcreate', 'tprint', and 'tproject'. +.ih +PARAMETERS +.ls table [file name template] +A list of tables for which column info is to be printed. +.le +.ls (nlist = 4) [integer, min=1, max=4] +The number of items to list. +The output will consist of 'nlist' columns, +one line for each column that is defined in the table. +The items listed out are column name (displayed for all 'nlist' values), +data type (displayed if 'nlist' is 2 or higher), +display format (if 'nlist' is 3 or higher), +units (if 'nlist' is 4). +If 'nlist = 1', only the column name will be displayed; +the output list may be edited and used as input to +'tprint', 'tdump,' 'tedit', 'tread', 'tproject', or 'tquery'. +The default of 4 can be used to generate +a column-description file for the 'tcreate' task. + +If a column contains an array of values at each row, +rather than just a single element, +the array size is shown in square brackets appended to the data type. +.le +.ih +EXAMPLES +1. Display the names, data types, print formats, and units of all the +columns in the table "example.tab": + +.nf + tt> tlcol example.tab +.fi + +2. Print (using the 'tprint' task) specific columns: +.nf + + tt> tlcol example.tab nlist=1 >colnames.lis + tt> edit colnames.lis + (Rearrange the column names and perhaps delete some of them.) + tt> tprint example.tab columns=@colnames.lis + +3. Create a new table based on the columns in "example.tab": + + tt> tlcol example.tab nlist=4 >colnames.lis + tt> edit colnames.lis + (Delete or modify some column descriptions and/or add new ones.) + tt> tcreate ex2.tab cdfile=colnames.lis ... +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +tinfo, tcreate, tdump +.endhelp diff --git a/pkg/utilities/nttools/doc/tlinear.hlp b/pkg/utilities/nttools/doc/tlinear.hlp new file mode 100644 index 00000000..66817fef --- /dev/null +++ b/pkg/utilities/nttools/doc/tlinear.hlp @@ -0,0 +1,127 @@ +.help tlinear Aug2000 tables +.ih +NAME +tlinear -- Fit a linear function to one or two table columns by linear +regression. +.ih +USAGE +tlinear intable outtable xcol ycol +.ih +DESCRIPTION +This task generates fitted Y values and their residuals in two columns. +These columns may be written to an output table, but cannot be written +to STDOUT--only the fit parameters can be written to STDOUT. +If there is more than one table in the input list then a separate fit +is made for each table. + +When a column of weights is used (see 'wcol'), +the weights will be applied when computing the +coefficients of the fit (a, b), +their standard deviations (siga2, sigb2), +and chi squared (chi2), +where the names in parentheses are the headings in +the output printed to STDOUT. +If any row has a weight that is exactly zero, +that row will not be counted in the "pts in fit" value. +The weights will NOT be used when computing +the RMS of the residuals and mean of the residuals +(residual rms, residual mean); +these are unweighted averages +except that rows with exactly zero weight will not be included. +.ih +PARAMETERS +.ls intable [file name template] +A list of input tables containing the columns to be fit. +A fit will be made of the columns specified by the 'xcol' and 'ycol' +parameters. If more than one file name is passed to 'intable', all of +the files must use the same column names. +.le +.ls outtable = STDOUT [file name template] +File names for creating output files, or STDOUT to send output to the screen. +If the value of this parameter is "STDOUT" then the parameters of the fit will +be written to STDOUT preceded by a header line (beginning with #) in tabular +form. +If 'outtable' is not "STDOUT" then the number of file +names must match the number +of names in 'intable', and the fitted Y values and residuals will be written +to an output table with the specified name. The parameters of the fit will +be written to the table header. +.le +.ls xcol [string] +Column name in the input tables to be fit. +The values in this column will be fit for the X axis. +(The same column name is used for each input table.) If a name is not specified +for the X values then row number is used. The values in the 'xcol' column will +be copied to 'outtable' unless the output is being directed to STDOUT. +.le +.ls ycol [string] +Column name in the input tables containing value to be fit for the Y axis. +(The same column name is used for each input table.) Values in 'ycol' will +be copied to 'outtable' unless 'outtable = STDOUT'. +.le +.ls (wcol) [string] +Column name in 'intable' that contains weight values for X and Y. +(The same column name is used for each input table.) If no column +name is passed to either the 'wcol' or 'scol' parameters, then a weight +of 1. is used. The value of the 'wcol' column is copied to 'outtable' unless +'outtable = STDOUT'. +.le +.ls (scol) [string] +Column in 'intable' containing the standard deviation of X and Y. +The X and Y values are weighted by the values in 'scol' +as the reciprocal of the values squared. (The same column name is used for each +input table.) If no value is passed to 'wcol' or 'scol', then +a weight of 1. is used. This task can accept either a weight value or a +standard deviation value, but not both. If both 'wcol' and 'scol' are +specified, then the weight column (i.e., 'wcol') will be used. +The value in the 'scol' column is written to 'outtable' unless 'outtable' += STDOUT. +.le +.ls (rows = "-") [string] +Range of rows to use for fitting the data. +The default "-" means that all rows are used. +(Type "help xtools.ranges" for more information.) +.le +.ls (outcoly = "yfit") [string] +Column name for fitted Y values. +This parameter is not used if 'outtable' = STDOUT. +This column will be double data type. +.le +.ls (outcolr = "yres") [string] +Name of the column to contain residuals. +This parameter is ignored if 'outtable' = STDOUT. +This column will be of double data type. +.le +.ih +EXAMPLES +1. Fit the values in the "flux" column in every table whose name begins with +"hr"; put all parameters of the fits in the ASCII file "fit.lis". + +.nf + tt> tlinear hr*.tab STDOUT "" flux > fit.lis +.fi + +2. Generate the same fits as in the previous example, but put the +results in tables, one output for each input table. For example, +the fitted Y values and +residuals for an input table named "hr465.tab" would be put in "hr465h.tab". + +.nf + tt> tlinear hr*.tab hr*%%h%.tab "" flux +.fi + +3. Fit the values in the "flux" column as a function of the values in the +"wavelength" column and write all the parameters of the fit to STDOUT. + +.nf + tt> tlinear hr*.tab STDOUT wavelength flux +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Betty Stobie. +.ih +SEE ALSO +ranges +.endhelp diff --git a/pkg/utilities/nttools/doc/tmatch.hlp b/pkg/utilities/nttools/doc/tmatch.hlp new file mode 100644 index 00000000..20b5abe4 --- /dev/null +++ b/pkg/utilities/nttools/doc/tmatch.hlp @@ -0,0 +1,225 @@ +.help tmatch Jan1999 tables +.ih +NAME +tmatch -- Find closest match between rows in two tables +.ih +USAGE +tmatch (input1, input2, output, match1, match2, maxnorm) +.ih +DESCRIPTION +This task combines rows from two tables into one. Rows are combined by +looking at each row in the first table and finding the row in the +second table whose match columns are closest to those in the first. +The distance between two rows is defined in the usual way to be the +square root of the sum of the squares of the difference between the +corresponding match columns. Rows are only written to the output table +if the distance between them is less than the distance specified by +maxnorm. This task converts match column units to degrees for the +purpose of computing the distance if the column units are recognized +angular units (seconds, minutes, degrees, hours, or radians or any +abbreviation of these). If the column units are blank or some +unrecognized string, no conversion is done. Thus, if the match column +is in some recognized angular units, maxnorm should be specified in +degrees. + +Columns named by the parameters 'incol1' and 'incol2' will be copied to +the output table. If these parameters are left blank, all columns will +be copied to the output table. Columns will have the same name in the +output table as in the input table, except that columns with the same +name in both input tables will have the suffix "_1" and "_2" added to +indicate which table they were copied from. + +This task optionally allows you to supply a set of weighting factors +that are multiplied by the difference between corresponding match +columns when computing the distance. These factors can be used to +supply units conversion when column units information is missing from +the input table or as a way to weight information from columns +containing distinct information. If factors are supplied, any column +units information is ignored. If the factors are left bank, they are +ignored and column units information is used to convert to degrees +when possible. + +If the match columns contain spherical coordinates, parameter 'sphere' +should be set to yes so that the distance on a sphere can be computed. +If the match columns do contain spherical units, the first column +should be the longitude column (such as right ascension) and the +second column should be the latitude column (such as declination). +Columns should also be in some recognized angular units, or a +conversion factor should be supplied explicitly. + +The task optionally produces a diagnostic output file if a file name +is supplied to parameter 'diagfile'. The diagnostic file contains the +rows from the first table that were not matched, the cases where +more than one row in the first table matched a single row in the +second table, and the ten matched rows in the with the largest +distance between them. Rows in the diagnostic output are identified by +their table number and row number and optionally by the contents of +the columns specified by the parameters 'nmcol1' and 'nmcol2'. + +This task differs from tjoin in two respects. First tjoin combines +tables on the basis of a single column, while this task can combine +tables based on multiple columns. Second, tjoin places every +combination of rows matching within the specified tolerance in the output +table, while this task only puts the closest match in the output table. +.ih +PARAMETERS +.ls input1 [string] +First input table name. +.le +.ls input2 [string] +Second input table name. +.le +.ls output [string] +Output table name. +.le +.ls match1 [string] +A column template describing columns from the first table used to +match the two tables. A column name template is a comma or whitespace +list of strings. Each string may either be a column name a pattern +containing wildcard characters which matches several column names. This +parameter will also accept the name of a list file (preceded by the +"@" character) containing column names to be matched. +If the first non-white character in the template +is the negation character (either "~" or "!"), +all columns NOT appearing in the list will be matched. +.le +.ls match2 [string] +A column name template describing columns from the second table used +to match the two tables. This parameter follows the same format rules +as 'match1'. The number of columns must equal those in 'match1'. +.le +.ls maxnorm min= 0.0, max=INDEF [real] +The distance between two rows must be less than 'maxnorm' in order for +them to match. Recognized angular units are converted to degrees +before computing the distance. The recognized units are seconds, +minutes, degrees, hours, radians, or any abbreviation of these. +.le +.ls (incol1 = " ") [string] +A column name template describing the columns to be copied from the +first input table to the output table. If this parameter is left blank +(the default) all columns in the first input table will be copied to +the output. +.le +.ls (incol2 = " ") [string] +A column name template describing the columns to be copied from the +second input table to the output table. If this parameter is left +blank (the default) all columns in the second input table will be +copied to the output. +.le +.ls (factor = " ") [string] +A comma or white space separated list of numeric factors multiplied by +the individual column differences when computing the distance between +rows in the first and second tables. If this parameter is left blank +(the default) conversion of angular units to degrees will be +performed, but not other weighting will be performed. If a list of +values is supplied, units conversion will NOT be performed, the +supplied numeric factors will be used instead. +.le +.ls (diagfile = " ") [string] +The name of the diagnostic output file. If the name is left blank (the +default) no diagnostic output is produced. Diagnostic output can be +sent to the terminal by setting this parameter to STDOUT or STDERR. +The diagnostic output contains a list of rows that were not matched, +cases where more than one row in the first table matched a single row +in the second table, and the ten pairs of rows with the largest +distance between them. +.le +.ls (nmcol1 = " ") [string] +A column template describing the columns from the first table that are +printed in the diagnostic output. The table and row number are always +printed, if this parameter is not blank, the specified columns are +also printed. +.le +.ls (nmcol2 = " ") [string] +A column template describing the columns from the second table that are +printed in the diagnostic output. +.le +.ls (sphere = no) [bool] +If this parameter is set to yes, a correction appropriate for +spherical coordinates will be applied to the first column +difference. The correction is the cosine of the average of the two +second column values. In order for this correction to be valid, the +first column must contain the longitude component and the second +column the latitude component. Units should be convertable to degrees +or an explicit conversion factor should be supplied. +.le +.ih +EXAMPLES +1. Two star catalogs are being matched. They both have the following +columns: + +.nf +Name CH*12 %12s "" +RA D %10.1h hours +Dec D %10.0h degrees +V R %7.2f "" +B-V R %7.2f "" +U-B R %7.2f "" +.fi + +To find the best match between the catalogs within a ten arcsecond +radius one would use the following command: + +.nf +tt> tmatch catalog1.tab catalog2.tab match.tab \ +>>> ra,dec ra,dec 0:00:10 sphere+ +.fi + +The search radius can either be supplied in sexagesimal notation, as +above, or in decimal degrees. + +2. Suppose the input catalogs did not contain units information, as +would be the case if they were text files. The units conversion could +then be supplied explicitly through the factor parameter: + +.nf +tt> tmatch catalog1.tab catalog2.tab match.tab \ +>>> ra,dec ra,dec 0:00:10 factor=15,1 sphere+ +.fi + +3. Suppose we want the output table to only contain the name from the +first catalog and get the rest of its information from the second +catalog. This could be done with the following command: + + +.nf +tt> tmatch catalog1.tab catalog2.tab match.tab \ +>>> ra,dec ra,dec 0:00:10 incol1=name sphere+ +.fi + +4. To get diagnostic output from the task, use the following command: + +.nf +tt> tmatch catalog1.tab catalog2.tab match.tab ra,dec ra,dec \ +>>> diag=diag.txt nmcol1=name nmcol2=name 0:00:10 sphere+ +.fi + +The following is a subset of the diagnostic output produced: + +.nf +The following objects matched the same object: +1:163 6601 GEM +1:164 6601 GEM +2:163 6601 GEM + + +The following objects have the largest norms: +Norm = 0.00253 +1:371 2319 SCO +2:371 2319 SCO + +Norm = 0.00247 +1:368 2101 SCO +2:368 2101 SCO +.fi + +The number before the colon is the table number, the number after the +colon is the row number, and the rest of the line is from the name +column. +.ih +REFERENCES +Written by Bernie Simon +.ih +SEE ALSO +tjoin +.endhelp diff --git a/pkg/utilities/nttools/doc/tmerge.hlp b/pkg/utilities/nttools/doc/tmerge.hlp new file mode 100644 index 00000000..301d7802 --- /dev/null +++ b/pkg/utilities/nttools/doc/tmerge.hlp @@ -0,0 +1,231 @@ +.help tmerge Jun1999 tables +.nj +.ih +NAME +tmerge -- Merge two tables, or append one to the other. +.ih +USAGE +tmerge intable outtable option +.ih +DESCRIPTION +This task is used to either merge or append tables, +depending on the option selected by the 'option' parameter. +The data type of each column is defined by +the first table in the input list containing that column. +If subsequent tables use the same column name, +then data are converted to the type defined by the first table. +Problems may occur when numerical data are written to +a boolean column or a narrow character column. + +The "merge" option is normally used for tables containing few, +if any, common columns. +When the user selects "merge", +an output table is created containing as many columns +as there are unique column names in all the input tables. +(But see the description of the 'allcols' parameter.) +The output table will have as many rows as the largest +number of rows in the input tables. +The input tables are read in order, +with all values being placed into the output table. +If different input tables have the same column names +then the first values put into the output table +will be overwritten by the later table values. +For example, if the two input tables both have the column name "X_VAL", +then for each row number, +the values written to the output table +will be taken from the second input table. +See below regarding text tables. + +On the other hand, if the "append" option is selected, all rows of +the first input table are written to the output table, followed by all +rows of the second table, and so on, until all input tables are written +to the output table. +The total number of output rows will be the sum +of the numbers of rows in the input tables. +Columns with the same name in different +input tables will be written into the same output column, but no data +will be overwritten because they are put into different rows. +The "append" option would normally be used for tables that have all +the same columns. + +An input table may have no rows. +Such a table may be used as the first input table +to control the order and definitions of columns in the output table. + +Header parameters are appended, +and parameters with the same keyword name +in different input tables are overwritten in the output file, +except for history and comment keywords. + +Care must be taken with text tables. +It is very likely that you would want +'allcols = yes' if 'option = merge' and +'allcols = no' if 'option = append'. +See the description of the 'allcols' parameter for details. +If the output table is a text file, +the line length may not be longer than 4095 characters, +which is a limitation for any text table. + +Column units are not checked. +If columns with the same name have different units +in two different input tables, +the merged (or appended) data are likely to have mixed units. +In addition, the column definition is taken from the first input table, +but some and perhaps all of the data would come from the second input table, +so the units in the output column definition would not be correct +for those data. +.ih +PARAMETERS +.ls intable [file name template] +Names of the tables to be merged or appended. This parameter will take +either a file name template describing several input tables, and may include +wildcard characters, or it will take the name of a list file preceded by the +"@" character; in the latter case the list file contains a list of file names +with each file name on a separate line. Wildcard characters should not be +used for file name extensions because files other than tables will be +processed, causing the program to crash. For example, if the directory +contains files "table.tab" and "table.lis", the command "tmerge tab*" would +open both files. +.le +.ls outtable [file name] +The name of the output table. +.le +.ls option = "merge" [string] +allowed values: merge | append + +Either merge the columns in each row of each input table--overwriting +previous values--or append files to each other. +See also 'allcols' below. +(These options are discussed in greater detail in the DESCRIPTION section.) +.le +.ls (allcols = yes) [boolean] +Define output table columns using columns from +all input tables? + +If 'allcols = no', the output table will contain +only those columns defined in the first input table. +If 'allcols = yes', the output table will contain +all columns from all input tables. +If 'option = merge', then it is likely that 'allcols' should be set to yes. + +For input tables that are simple text tables +(i.e. that do not contain explicit column definitions), +the 'allcols' parameter serves an additional function. +When 'allcols = yes' the name of each column +in a simple text table is changed +to be "c" followed by the column number in the output table. +This is intended to make the column names unique +in order to allow merging text tables +without having the columns overwrite previously written columns. +Since the column names in simple text tables are just c1, c2, etc., +columns would overwrite previously written columns in the output +if the names were not modified. +If all input tables are simple text tables, +and the output is also a text table, +the new names will be discarded, +so the net effect of this scheme is just to preserve all input data. +If the output is a binary table, however, +the modified column names will be retained. +If the modified column names turn out not to be unique, +a warning message will be printed. +.le +.ls (tbltype = "default") [string, allowed values: default | row | +column | text] + +This parameter specifies the table type. +Setting 'tbltype' to "row" or "column" results in an stsdas binary table, +the contents of which may be either row ordered or column ordered; +row order is recommended. +You can also specify that the output be a text table. +The default ('tbltype = "default"') means that the type of the output table +will be taken from the first input table. + +If the extension of the output file name is ".fits" or ".??f", +the table to be created will be a BINTABLE extension in a FITS file, +regardless of how 'tbltype' is set. +.le +.ls (allrows = 100) [integer, min=1, max=INDEF] +The number of rows to allocate. +This parameter is only used for column-ordered tables +(specified by the 'tbltype' parameter). +The 'allrows' parameter is the minimum number of rows an output +table will contain. +If the number of rows required by the input tables +is greater than 'allrows' then the number of rows in the output table will +be greater than 'allrows'. +If 'option = merge', then the total number of rows will be +the larger of 'allrows' or the number of rows in the largest table. +If 'option = append', the total rows in the output table will be the larger +of 'allrows' or the total number of rows in all input tables. +.le +.ls (extracol = 0) [integer, min=0, max=INDEF] +Extra space to be reserved for columns in the output table. + +This parameter is relevant only for a row-ordered table +(specified by the 'tbltype' parameter). +The default value of zero is normally appropriate, +but if you expect to define additional columns in the output table +at a later time +then you can allocate the necessary space +by specifying a value for 'extracol'. +One unit of space is taken by each single-precision real value, +integer value, or boolean value. +A double-precision column requires two units of allocated space, +and a character-string column takes one unit of space for each four +characters, or fraction thereof. +.le +.ih +EXAMPLES +.nf +1. Suppose you have the following two tables. + +tbl1.tab: + one two three + --- --- ----- + 1 -17 alpha + 2 -19 beta + 3 -23 gamma + +tbl2.tab: + one three four + --- ----- ---- + 27 beta 3.14 + 28 delta 2.72 + +then the statement + + cl> tmerge tbl1,tbl2 mrg merge + +would create the following output table: + +mrg.tab: + one two three four + --- --- ----- ---- + 27 -17 beta 3.14 + 28 -19 delta 2.72 + 3 -23 gamma INDEF + +while the statement + + cl> tmerge tbl1,tbl2 app append + +would create the following table: + +app.tab: + one two three four + --- --- ----- ---- + 1 -17 alpha INDEF + 2 -19 beta INDEF + 3 -23 gamma INDEF + 27 INDEF beta 3.14 + 28 INDEF delta 2.72 +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +tselect, tproject, and proto.joinlines for text files +.endhelp diff --git a/pkg/utilities/nttools/doc/tprint.hlp b/pkg/utilities/nttools/doc/tprint.hlp new file mode 100644 index 00000000..47690159 --- /dev/null +++ b/pkg/utilities/nttools/doc/tprint.hlp @@ -0,0 +1,276 @@ +.help tprint Aug1999 tables +.nj +.ih +NAME +tprint -- Convert an STSDAS table to a readable ASCII file. +.ih +USAGE +tprint table +.ih +DESCRIPTION +This task is similar to the 'tdump' task in that it takes an STSDAS +table and produces a file in ASCII format; +however, this task offers more control over the appearance +of the final product and better prepares it for printing. +Formatting options are available +to control the width and length of a page, +and to produce the output in HTML, TeX or LaTeX format. + +By default, all rows and columns in the input tables will be printed, +but the 'rows' and 'columns' parameters can be used +to limit the range of rows and columns, respectively, that will be used. +When using the TeX or LaTeX options, +the number of output columns is limited to 52. +For the HTML option, +all the rows and columns that are to be printed +will be written to one HTML table, +rather than broken into pages. +There is no limit to the number of columns in ASCII format; +however, if the aggregate column width exceeds the page width +the output will be produced in sections +with columns kept together on a page--lines will not wrap. +If different columns for each row are printed on separate pages, +the row number will appear on each page, if 'showrow = yes'. + +The output will be printed to the standard output. +.ih +PARAMETERS +.ls table [file name template] +The file names of tables to be printed. +This parameter will accept a general file name template, +containing wildcard characters, +individual file names with each file name separated by a comma, +or the name of a list file (preceded by the "@" character) +containing the file names of all tables to be processed. +If more than one table is to be processed, +a blank line will be printed between tables. +.le +.ls (prparam = no) [boolean] +Should the header parameters be printed? +.le +.ls (prdata = yes) [boolean] +Should the table data be printed? +.le +.ls (pwidth = 80) [integer, min=40, max=INDEF] +If the output is redirected, +'pwidth' specifies the width of the output page; +otherwise, the screen size is taken from the environment variable 'ttyncols'. +Columns that are too wide to fit within this page size +(allowing also for the row number) will be truncated. + +This parameter is not used if option = "html". +.le +.ls (plength = 0) [integer, min=0, max=INDEF] +Lines of data per page. +This is the number of rows from the table to be printed on each page; +it does not include the line of column names. +It does, however, include any blank lines inserted in the data +because the user specified a value for 'lgroup'. +The default of zero gives no page breaks. + +This parameter is not used if option = "html". + +If the 'sp_col' parameter is not null +or if the 'lgroup' parameter is greater than zero, +the blank lines between groups are included in the count of lines per page. +Thus 'lgroup = 50' and 'plength = 51' would be consistent +and would give the same result as 'lgroup = 0', 'plength = 50'. +.le +.ls (showrow = yes) [boolean] +Print the number of each row? + +If more than one page is needed in order to print all the columns specified, +then the row numbers will be printed on each page. +If 'showrow = no' then row numbers are not printed. +.le +.ls (orig_row = yes) [boolean] +Print row numbers of the underlying table? + +This parameter only has an effect if a row selector expression +was included with the table name, +in which case the table appears to have fewer rows +than are actually present in the underlying table +(the complete table, including all rows). +When 'orig_row' is yes, the default, +the row numbers printed are those in the underlying table; +when 'orig_row' is no, +the selected rows are numbered sequentially starting with one, +as if those were the only rows in the table. +.le +.ls (showhdr = yes) [boolean] +Print header information? + +The table name, date of last modification, +and column names are printed only if 'showhdr = yes'. +If the 'option' parameter (see below) is set to either "latex" or "tex", +then 'showhdr' will affect the printing of +the default macro definitions for column separators +and the end-of-line string as well as the begin-table string +(i.e., "\begin{tabular}..." or "\halign..."). +.le +.ls (showunits = yes) [boolean] +Print the units for each column? If 'showunits = yes' +then the column units will be printed on the line below the column names. +.le +.ls (columns = "") [string] +The names of the columns to be printed. +An alternative way to do this +is to use a column selector with the table name +(type "help selectors" for more information). + +A null or blank string means print all columns. +This parameter is a column template--that is, +either a list of column names +or a template that can contain wildcard characters. +The column names should be separated by commas or white space. +The list of column names can be placed in a file +and the name of the file preceded by "@" passed to 'columns'. +If the first character in the column template +is the negation character (either "~" or "!"), +all columns NOT named will be printed. + +If you want to use a list file for this parameter, +the 'tlcol' task can be used to make the list +(be sure to set the 'nlist' parameter to 1). +Using the 'tlcol' task can eliminate potential problems +caused by incorrect spelling. +The list produced by 'tlcol' can also be edited to +rearrange column names (to change the order for printing) +or to delete unwanted columns. +.le +.ls (rows = "-") [string] +The range of rows which are to be printed. +An alternative way to do this +is to use a row selector with the table name +(type "help selectors" for more information). + +This parameter takes a character string +defining either specific rows to be printed, +a range of rows, or upper or lower limits on row numbers. +The default value "-" means print all rows. +The first ten rows could be specified as rows="1-10" or just rows="-10". +To print the first ten rows +and all rows from 900 through the last (inclusive), use rows="-10,900-". +Setting rows="1,3,7,23" will print only those four rows. +It is not an error to specify rows larger than the largest row number; +excess row numbers will simply be ignored. +(For more information type "help ranges".) +.le +.ls (option = "plain") [string, allowed values: plain | html | latex | tex] +The format in which output will be produced. +If option = "plain", the output will be ordinary ASCII text which may +be read or printed directly. +(See also the 'align' parameter, below.) + +If option = "html", +the output will be formatted with HTML tags, +and the output should be redirected to a file having the extension ".html". + +If option = "latex", +the output will be formatted for use as input to LaTeX, +and if option = "tex", +the output will be formatted for use as input to TeX. +In these two cases the output should be redirected to a file having +the extension ".tex". +Each value in each row will be preceded by a column-separator of the +form "\cola" through "\colz", "\colA" through "\colZ". +(Yes, there +is a limit of 52 columns to be printed on one page.) If the row number +is printed (i.e., by using the 'showrow' parameter) it will +be preceded by the string "\colzero"; the string "\cola" always +precedes the first column from the table. +The default definitions assign "\null" to the first of these +(either "\colzero" or "\cola") and assign "&" to all the rest. +Each row may span several physical rows and is terminated by "\eol", +which has the default definition of "\\" or "\cr" as appropriate. +(See also the description of the parameter 'showhdr'). +.le +.ls (align = yes) [boolean] +Increase column width to align with header? This parameter is only useful +when option = "plain". +If 'align = no', the print format stored in the table for each column +will be used without modification. +This can cause a problem in that some +column names may be longer that the field width for those columns, +consequently, the column names and their values will be misaligned +(this is especially true of subsequent columns). +The default value 'align = yes' will force the columns to be aligned +with the column names regardless of the print format. +Note that you can set 'showhdr = no' but 'align = yes', in which case the +column names will not be printed, but the columns will be spaced the +same as if the names were printed. +.le +.ls (sp_col = "") [string] +This is the name of a column in the table. +If it is specified (non-null), +and if the column is found in the input table, +a blank line will be printed +whenever the value in this column changes +from the value in the preceding row +(or from the preceding element, +if 'sp_col' contains arrays). + +The equality test is made on formatted +values in the column so that the user has more control over spacing +when the data type of 'sp_col' is either real or double. +The print format may be changed using either the 'tedit' or 'tchcol' tasks. +Both 'sp_col' and 'lgroup' may be used together, +which may be useful if the 'sp_col' column does not change very often. +.le +.ls (lgroup = 0) [integer, min=0, max=INDEF] +Print a blank line after each 'lgroup' lines. +If 'lgroup' is greater than zero, +a blank line will be printed between each block of 'lgroup' lines. +These blank lines are included in the count for 'plength' (page length). +For example, if lgroup = 10 and plength = 55, +five groups of ten lines will be produced for each page; +lgroup = 5, plength = 60 will +give ten groups of five lines per page. +The count of lines for these groups is reset at the beginning of each page, +so even if lgroup+1 does not divide into 'plength', +the first group on each page will have 'lgroup' lines. + +If any column that is being printed contains array elements +rather than just scalar values, +grouping by 'lgroup' will be applied to array elements +rather than to row numbers. +If option = "plain" +and the window width (or 'pwidth' if output is redirected) +is not large enough for all the columns, +the spacing can be by row number on some pages +and element number on other pages, +depending on which columns fit on those pages +(i.e. whether the columns contain arrays). +.le +.ih +EXAMPLES +1. Print all tables in the default directory. + +.nf + tt> tprint *.tab +.fi + +2. Print 'junk.tab', but rearrange the columns. + +.nf + tt> tlcol junk nlist=1 >colnames.lis + tt> edit colnames.lis + (Rearrange the column names and perhaps delete some of them.) + tt> tprint junk columns=@colnames.lis +.fi + +3. After using the 'tinfo' task to find that 'big.tab' has 100000 rows, +print the first five and last five rows. + +.nf + tt> tprint big rows="1-5,99996-" +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +tdump, ranges +.endhelp diff --git a/pkg/utilities/nttools/doc/tproduct.hlp b/pkg/utilities/nttools/doc/tproduct.hlp new file mode 100644 index 00000000..8b9c2534 --- /dev/null +++ b/pkg/utilities/nttools/doc/tproduct.hlp @@ -0,0 +1,48 @@ +.help tproduct Dec90 tables +.ih +NAME +tproduct -- Form the Cartesian product of two tables. +.ih +USAGE +tproduct intable1 intable2 outtable +.ih +DESCRIPTION +This task creates an output table which is the Cartesian product of two input +tables. This Cartesian product consists of every possible combination of the +rows of the two input tables. Therefore, the number of rows in the output table +is the product of the number of rows in the two input tables. The output table +will contain all the columns from both input tables. If a column name in the +first input table is the same as a column name in the second input table, this +task tries to create a unique name by appending "_1" to the first name and "_2" +to the second name. If the task cannot create a unique name in this way, it +stops with an error. +.ih +PARAMETERS +.ls intable1 [file name] +First input table. +.le +.ls intable2 [file name] +Second input table. +.le +.ls outtable [file name] +Output table containing the possible Cartesian products. +.le +.ih +EXAMPLES +1. Find all persons sharing a phone from a phone list: + +.nf +tt> tproduct phone.tab phone.tab phone.tmp +tt> tselect phone.tmp share.tmp "phone_1 == phone_2 && name_1 < name_2" +tt> tproject share.tmp share.tab phone_2 inc- +tt> delete *.tmp +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +tselect, tproject, tjoin +.endhelp diff --git a/pkg/utilities/nttools/doc/tproject.hlp b/pkg/utilities/nttools/doc/tproject.hlp new file mode 100644 index 00000000..7ab88158 --- /dev/null +++ b/pkg/utilities/nttools/doc/tproject.hlp @@ -0,0 +1,79 @@ +.help tproject May1999 tables +.ih +NAME +tproject -- Create a new table from selected columns of an old table. +.ih +USAGE +tproject intable outtable columns +.ih +DESCRIPTION +This task will create a new table containing a subset of the columns in an +old table. The column names are given as a column name template. There is an +optional parameter, 'uniq', that filters out duplicate rows from the +new table. + +If you do not need to eliminate duplicate rows, you can also use tcopy +with a column selector on the input table name. +.ih +PARAMETERS +.ls intable [file name template] +The table(s) from which the columns are to be copied. If input is +redirected, this parameter will ignored and input will be read from +STDIN instead. +.le +.ls outtable [file name template] +The new table(s) containing the copied columns. +The number of output tables must equal the number of input tables. +.le +.ls columns [string] +This is the column template describing those columns that should be +selected from the old table and put in the new table. +A column template consists of a list +of either column names or column name templates that include wildcard +characters. Column names (or templates) are separated by commas or white space. +This parameter will accept the name of a list file (preceded by the "@" +character) containing all of the column names to be selected. +If the first non-white character in the column template +is the negation character (either "~" or "!"), +the new table will contain those columns +whose names DO NOT match rest of the column template. +.le +.ls (uniq = no) [boolean] +Eliminate duplicate rows from the output table? + +If 'unique' is set to "yes", only one of each set of duplicate rows is +included in the output table. All columns in the output table must be +identical for the row to be removed. String comparisons are case +sensitive. Care should be used in setting this option for +large tables, as it significantly increases the running time. +.le +.ih +EXAMPLES +1. Extract the star names, magnitudes, and colors from a catalog: + +.nf +tt> tproject starcat.tab starmag.tab "name,mag,color" +.fi + +2. Exclude the measurement error from a set of spectra. Change the file name +extensions from ".tab" to ".tbl": + +.nf +tt> tproject *.tab *.%tab%tbl% "!error" +.fi + +3. Create a new table of engineering parameters using a column template stored +in the file 'columns.dat'. Eliminate duplicate rows: + +.nf +tt> tproject datalog.tab sublog.tab @columns.dat uniq+ +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +tselect, tjoin, tproduct,tcopy +.endhelp diff --git a/pkg/utilities/nttools/doc/tquery.hlp b/pkg/utilities/nttools/doc/tquery.hlp new file mode 100644 index 00000000..61857fd7 --- /dev/null +++ b/pkg/utilities/nttools/doc/tquery.hlp @@ -0,0 +1,115 @@ +.help tquery Jan1999 tables +.ih +NAME +tquery -- Create a new table from selected rows and columns of an old table. +.ih +USAGE +tquery intable outtable expr columns sort +.ih +DESCRIPTION +This task combines the functions of the tasks 'tselect', 'tproject', and +'tsort' to create a more powerful task that can produce a sorted table of +user-selected rows and columns. +It can be used whenever you want to do more than one of these operations +without creating intermediate tables. This task creates a new table +containing a subset of the rows and columns in an old table. The rows in the +new table can be sorted on any column or combination of columns. The select, +project, and sort operations are controlled by the parameters 'expr', +'columns', and 'sort', +respectively. If the value of any of these parameters is a null or +blank string, the corresponding operation is not performed. Otherwise, the rows +are selected whenever the row meets the conditions defined by 'expr'; +columns are +selected by the 'columns' parameter, and rows are +sorted on the columns named in 'sort'. The hidden parameter 'uniq' is used +to eliminate duplicate rows from the output table. The hidden parameter +'ascend' sorts the table in ascending order, and the parameter 'casesens' +specifies whether sort conditions are to be case sensitive. +.ih +PARAMETERS +.ls intable [file name template] +Table(s) from which rows are copied. If input is redirected, this +parameter will ignored and input will be read from STDIN instead. +.le +.ls outtable [file name template] +The new table(s) containing the copied rows. +The number of output tables must equal the number of input tables. +.le +.ls expr [string] +The boolean expression which determines which rows are copied to the new +table. The expression may be placed in a file and the name of the file +preceeded by a '@' can be given in its place. If the expression is null +or blank, all rows are selected. The syntax and method used to define +this boolean expression is explained in detail in the help file for the +'tselect' task (type "help tselect" for more information). +.le +.ls columns [string] +Column template describing the columns that are to be selected +from the old table. A column template consists of a list +of column names, which can include wildcard characters. +The column names, or patterns, are separated by commas or white space. +The list of columns can be placed in a file and then +the name of that file passed to 'columns' (preceded by +the "@" character). If the first non-white character in the template +is the negation character (either "~" or "!"), +the new table will contain those columns +that do NOT match the column template. If the column template +is null or blank, all columns will be selected. +.le +.ls sort [string] +Column template describing the columns to be sorted. The +first column name is the primary sort key with subsequent columns +used to break ties. If this parameter +is null or blank, no sort will be done. +.le +.ls (uniq = no) [boolean] +Make sure all rows are unique in a table? + +If 'unique' is set to "yes", only one of each set of duplicate rows is included +in the output table. All columns in the output table must be identical for +the row to be removed. String comparisons are case sensitive. Care should +be used in setting this option for large tables, as it significantly increases +the running time. +.le +.ls (ascend = yes) [boolean] +Should sorts be performed in ascending order? + +If 'ascend = yes', the table is sorted in ascending order, with the first +row containing the smallest value of the sorted column. Otherwise, the table +is sorted in descending order, with the largest value first. +.le +.ls (casesens = yes) [boolean] +Are sort operations case sensitive? + +If 'casesens = yes', sorts on character columns are case sensitive, with upper +case letters preceding lower case. Otherwise, the sort is not case +sensitive. +.le +.ih +EXAMPLES +1. Extract all binary stars from a catalog; write their names, magnitudes, +and colors to a new table, sorted on magnitude: + +.nf +tt> tquery starcat.tab binary.tab binary name,mag,color mag +.fi + +2. Remove duplicate rows from a set of tables. Otherwise, leave the tables +unchanged. Using file name editing (i.e., the "%" characters to delineate +old strings and new strings), change the file name extensions from ".tab" +to ".tbl". + +.nf +tt> tquery *.tab *.%tab%tbl% "" "" "" uniq+ +.fi +.ih +BUGS +Column names must be set off from operators by blanks in the expression so +that they can be correctly parsed by the expression evaluator. +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +tsort, tselect, tproject +.endhelp diff --git a/pkg/utilities/nttools/doc/tread.hlp b/pkg/utilities/nttools/doc/tread.hlp new file mode 100644 index 00000000..871ec66f --- /dev/null +++ b/pkg/utilities/nttools/doc/tread.hlp @@ -0,0 +1,159 @@ +.help tread Aug91 tables +.ih +NAME +tread -- View a table (read only). +.ih +USAGE +tread table +.ih +DESCRIPTION +The 'tread' task is a read-only version of 'tedit', the screen editor for STSDAS +tables. 'tread' lets you view a table by moving the cursor around the +screen with the cursor keys. The screen scrolls both sideways and up +and down as you move the cursor, so all elements of the table can be +reached. Other editing commands are entered on the command line. To +switch from table editing mode to command line mode, you press the +exit key (generally bound to Control-Z, though this can be changed). +When your +command is completed, the editor returns to table editing mode, unless +the command exits the editor. The most important commands in command +mode are `help' and `exit'. The `help' command displays all the +editing key bindings and the command line commands. The `exit' command +will get you out of the editor. + +Some editing commands are entered from the command line in command +mode. To get to command line mode, press the exit key (Control-Z). +If you enter a +blank line, the editor will +return to table editing mode. Some commands take arguments. They can +be included when the command is entered, or if they are omitted, the +editor will prompt you for their values. If the argument has embedded +blanks, the argument should be enclosed in quotes if passed on the +command line. No quotes should be used if the argument is entered +interactively. When the editor interactively prompts you for a command +argument it will also display a default value for the argument. +Pressing the return key gets the default value. Some command names are +two +words long, for example, "find forward". Usually the second word is +optional and modifies the meaning of the first. If the second word is +not optional and you omit it, the editor will prompt you for it. All +command names can be abbreviated to one or more letters. If the +command name is two words long, both words can be abbreviated to one +or more letters. + +The following commands are used by 'tread': +.ls exit +Exit the table editor. +.le +.ls find +Find the next row in the table which makes true and move +the cursor to that row. The expression has the same syntax as an +expression in a Fortran if statement. The variables in the expression +are column names. For more information on the syntax of the +expression, read the help for the 'tselect' task. The direction of the search +depends +upon previous find commands. By default the search direction is forward; +however, if a "find backwards" command has been executed previously, +searches will be done in a backwards direction until a "find forward" +command is executed. +.le +.ls find forward +Find the next row in the table which makes true and move the +cursor to that row. The search is done in the forwards direction. +.le +.ls find backwards +Find the next row in the table which makes true and move the +cursor to that row. The search is done in the backwards direction. +.le +.ls goto +Move the cursor to and . +.le +.ls help +Display online help information for the table editor. The help includes +a brief description of each command line command and the key bindings +for table editing commands. +.le +.ls next +Repeat the previous find command, using the same expression and search +direction that was used with it. +.le +.ls next forward +Repeat the previous find command, changing the search direction to +forwards. +.le +.ls next backwards +Repeat the previous find command, changing the search direction to +backwards. +.le +.ls quit +Exit the table editor. +.le + +The bindings to the table editing keys are read from the edcap file. +This is the file that defines key bindings for the +parameter editor and history editor. The edcap file defines key +bindings that resemble those of commonly used text editors. Three +edcap files are distributed with IRAF. They define key bindings which +resemble EDT, Emacs, and vi. These edcap files are located in the 'dev$' +directory and have the extension '.ed'. The appropriate file is chosen +according to the value of the environment variable 'EDITOR'. If you +want to customize the key bindings of the table editor, copy the +appropriate edcap file from the 'dev$' directory to your 'home$' directory +and edit the second column. The table editor searches your +home directory first for the edcap file and if it does not find it, +searches the 'dev$' directory. + +The table editor also uses the termcap file to determine the screen +size and the escape sequences used to modify the screen. There are +entries in the termcap file for almost all terminal types. The proper +entry is selected according to the environment variable terminal. To +change your terminal type or the screen size, use the IRAF 'stty' +command. + +.ih +PARAMETERS +.ls table [string] +Name of the table to be edited. The editor checks for the +existence of the table and its access mode before editing. The table +must exist in order to edit it with 'tread'. +.le +.ls (columns = "") [string] +Names of the columns to be edited. +A null or blank string means edit all columns. +A column template consists of a list of either +column names or column patterns containing the usual pattern matching +meta-characters. The names or patterns are separated by commas or +white space. The list can be placed in a file and the name of the +file preceded by an "@" character. +If the first character in the column template is a bang (!), +all columns NOT named will be displayed. + +The 'tlcol' task (with the 'nlist' parameter set to 1) may be used to generate a +list of +column names so there is no question about spelling. This list may be +edited to rearrange (or delete) the names, and then pass the list to this task +by preceding the its file name with an "@", for example, + +tt> tedit junk columns=@colnames.lis +.le +.ls (silent = no) [boolean] +Turn off the bell indicating warning messages? +.le +.ih +EXAMPLES +1. Display only the columns 'SHARP' and 'ROUND' from the table 'm12b.tab': + +.nf +tt> tread m12b columns="SHARP,ROUND" +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +tedit, tprint, tselect, stty + +Type "help tables opt=sys" for a description of the 'tables' package. +.endhelp diff --git a/pkg/utilities/nttools/doc/trebin.hlp b/pkg/utilities/nttools/doc/trebin.hlp new file mode 100644 index 00000000..293c08ec --- /dev/null +++ b/pkg/utilities/nttools/doc/trebin.hlp @@ -0,0 +1,257 @@ +.help trebin Jul2000 tables +.nj +.ih +NAME +trebin -- Resample tables. +.ih +USAGE +trebin intable outtable column start end step +.ih +DESCRIPTION +This task resamples tables. +The grid on which to interpolate an input table +may be specified either by a table giving explicit values +or by start, end, and step values for uniform spacing. +The column names in the output table +will be the same as in the input table. + +If the independent variable column ('column') +in the input table contains scalar values, +each numeric column in the input table will be rebinned +to the values of the output independent variable. +Character and boolean columns +will not be copied to the output table. +Columns that contain arrays will also not be copied to output. +On the other hand, +if the input independent variable column contains arrays +rather than scalar values, +then each row of the input table will be rebinned individually. +Scalar columns will be copied to output unchanged. +Array columns which have the same length as 'column' +will be rebinned and written to the output table; +if the array size is not the same, +the column will not be copied to output. + +Except for function = "linear", +the output values are obtained by interpolation, not by fitting. +The distinction is important when rebinning to a spacing ('step') +that is significantly coarser than the spacing of the input data. +For functions other than linear, +each interpolated value is obtained as follows. +The values of the input data +nearest the current output independent variable value (X) are selected; +the input data are then interpolated at X +to obtain the value to write to the output table. +For function = "nearest", only one input point is used; +for function = "poly3" or "spline", four input points are used. +This is appropriate for rebinning +to a spacing not much different from the input data. +For resampling noisy data +to a significantly wider spacing than the input data, however, +these options will give very poor results. +In the latter case, function = "linear" (the default) should be used. +This option uses a linear fit to all the data +within an interval of width 'step' centered on each output X value. +If there are fewer than two input points in a given interval, however, +the value is interpolated the same way as is done for the other functions; +that is, the two input points nearest to X are selected, +and the value is interpolated at X +(note that these two points can be outside the 'step' interval). + +A significant limitation to this task is that +there is no option to conserve total counts. +'trebin' averages the data values, +rather than summing the input bins. +What 'trebin' does is appropriate for flux-calibrated spectra, +or for time series data expressed as count rate, +but it would not be correct for data in counts, +or for count rate spectra. +.ih +PARAMETERS +.ls intable [file name template] +List of input tables to be resampled. +.le +.ls outtable [file name template] +Output tables or directory. +The number of output tables must match the number of input tables unless +'outtable' is a directory name. +.le +.ls column [string] +Name of the independent variable column in the input table, +i.e., the column on which the data are being resampled. +The same column name is used for all input tables. +The values in this column must be +either monotonically increasing or decreasing. +INDEF values and trailing 'padvalue' (described below) will be ignored. + +The data type of the column is assumed to be a numeric type. +.le +.ls start [real] +If the independent variable values at which to interpolate the input values +are to be uniformly spaced, +they may be specified using 'start', 'end', and 'step'. +'start' is the first value of the output independent variable. + +See also 'xtable'; +'start', 'end', and 'step' will be ignored if 'xtable' was specified. +.le +.ls end [real] +Last value of the independent variable. +This may be rounded up by a fraction of 'step' to ensure that the entire +range from 'start' to 'end' is included in the output table. +.le +.ls step [real] +Increment in independent variable. +The sign of 'step' is ignored; +internally to 'trebin' the sign will be set to negative +if 'start' is larger than 'end'. + +If 'start' and 'end' are the same, +the output table will contain one row, +and 'step' will only be used for the case of function = "linear". +For other values of 'function', +since the data will be interpolated at just the one point 'start', +the step size will not be needed. +.le +.ls (xtable) [file name template] +The independent variable values at which to interpolate the input values +can either be specified explicitly with 'xtable' +or computed using 'start', 'end', 'step'. +If 'xtable' is specified, +there must either be just one table name, +or the number of names must be the same as +the number of names in 'intable'. +If there is only one 'xtable', +it will be used for all input tables. + +'xtable' must contain only one column. +The name of the column does not matter; +it does not need to be the same as given by 'column'. +If the actual table contains more than one column, +use the column selector syntax to specify which one to use. +The column may contain either scalar values or arrays. +If the column contains arrays, +there must be only one row; +if the actual table contains more than one row, +use the row selector syntax to specify which one to use. + +The data type of the column is assumed to be a numeric type. +.le +.ls (function = "linear") [string, allowed values: nearest | linear | +poly3 | spline] + +Interpolation function. +There must be at least four rows in the input table +for cubic polynomial or cubic spline interpolation. +Two rows are required for linear interpolation, +and only one for nearest-neighbor. + +The "linear" option uses a linear fit, +while all other functions are interpolations +using only the required number of points +nearest the value of the independent variable. + +If an input table does not contain enough rows, +or if a column being interpolated contains INDEF values +so that the total number of values is insufficient for interpolation, +the output column will be entirely INDEF; +if verbose = yes, a message will be printed. +.le +.ls (extrapolate = no) [boolean] +Extrapolate if out of bounds? See 'value' below. +.le +.ls (value = INDEF) [real] +Value to use if out of bounds. +The independent variable values +at which the input table is to be interpolated +may fall outside the range of values +in the independent variable column in the input table. +The value to write to the output table +for out of bounds independent variables depends on +the 'extrapolate' and 'value' parameters. +If 'extrapolate' is yes, then 'value' is ignored, +and the interpolation function is used for extrapolation. +If 'extrapolate' is no, +then 'value' is written to each dependent variable column +for each row that the independent variable +is outside the range of values in the input table. +Note that for columns of type integer or short, +'value' should be within the range of possible values of that type, +and if 'value' contains a fractional part +it will be rounded to the nearest integer. +.le +.ls (padvalue = INDEF) [real] +Trailing INDEF values in the independent variable column +(either in 'intable' or in 'xtable') +will be ignored. +'padvalue' can be used to specify an additional value, +such as zero, +which will also be ignored +if it occurs at the end of an array of independent variable values. +Values will be trimmed off the end of the array +until a value that is neither INDEF nor 'padvalue' is encountered. +.le +.ls (verbose = yes) [boolean] +If verbose = yes, +the input and output table names will be printed as they are processed, +and the names of columns that are not being copied to output +will also be printed. +.le +.ls (Version) [string] +This gives the date of installation of the current version. +.le +.ih +EXAMPLES +1. Resample all the columns in all tables beginning with "hr" so the values +in the "Wavelength" column range from 3000 to 8000 in steps of 10. +The output tables will have the same names, but will be written in the +directory "home$spec" (which should be different from the default directory). + +.nf + tt> trebin hr*.tab "home$spec/" Wavelength 3000. 8000. 10. +.fi + +2. Interpolate the text table "in" at a single point, +where the value in column one is 5, +and print the results on the standard output. + +.nf + tt> trebin in STDOUT c1 5. 5. 0. +.fi + +3. Interpolate the table from example 2 +onto the array of independent variable values +in column "wavelength" at row 37 of "x1d.fits". +As in example 2, +the independent variable in "in" is the first column, "c1". + +.nf + tt> trebin in STDOUT c1 xtable="x1d.fits[r:row=37][c:wavelength]" +.fi +.ih +BUGS +A column which contains an integer bit mask +will be interpolated as if it were an ordinary numeric column, +which is not the correct behavior. + +Sometimes a table contains array columns +where the allocated array size is (or can be) +larger than the number of elements actually used. +In this case, a scalar column might be used +to specify the effective array length. +The array size in the output table +will typically be different from the array size in the input table; +'trebin' will update the allocated array size, +but it will not modify any scalar column that gives the effective array size. +.ih +REFERENCES +This task was written by Phil Hodge. +The following Numerical Recipes subroutines are used by this task: +TUCSPL, TUHUNT, TUIEP3, and TUISPL. +Numerical Recipes was written by W.H. Press, B.P. Flannery, +S.A. Teukolsky, and W.T. Vetterling. +.ih +SEE ALSO +Type "help tables opt=sys" for a higher-level description of the 'tables' +package. +.endhelp diff --git a/pkg/utilities/nttools/doc/tselect.hlp b/pkg/utilities/nttools/doc/tselect.hlp new file mode 100644 index 00000000..56299faa --- /dev/null +++ b/pkg/utilities/nttools/doc/tselect.hlp @@ -0,0 +1,147 @@ +.help tselect Jul92 tables +.ih +NAME +tselect -- Create a new table from selected rows of an old table. +.ih +USAGE +tselect intable outtable expr +.ih +DESCRIPTION +This task creates a new table from a subset of rows in an input table. +The rows are selected on the basis of a boolean expression whose +variables are table column names. If, after substituting the values associated +with a particular row into the column name variables, the expression evaluates +to yes, that row is included in the output table. Boolean operators can be used +in the expression in either their Fortran or SPP forms. The following boolean +operators can be used in the expression: + +.nf +equal .eq. == not equal .ne. != +less than .lt. < less than or equal .le. <= +greater than .gt. > greater than or equal .ge. >= +or .or. || and .and. && +negation .not. ! pattern match ?= +.fi + +The pattern match operator (?=) has no corresponding Fortran form. It takes a +string expression as its first argument and a pattern as its second argument. +The result is "yes" if the pattern is contained in the string expression. +Patterns are strings which may contain meta-characters (i.e., wildcard +characters used in pattern matching). +The meta-characters themselves can be matched by preceeding them with the escape +character (\). +The meta-characters are: + +.nf +beginning of string ^ end of string $ +one character ? zero or more characters * +white space # escape character \ +begin ignoring case { end ignore case } +begin character class [ end character class ] +not, in char class ^ range, in char class - +.fi + +The expression may also include arithmetic operators and functions. +Trigonometric functions use degrees, not radians. The following arithmetic +operators and functions can be used in the expression: + +.nf +addition + subtraction - +multiplication * division / +negation - exponentiation ** +concatenation // date difference delta(x,y) +absolute value abs(x) cosine cos(x) +sine sin(x) tangent tan(x) +arc cosine acos(x) arc sine asin(x) +arc tangent atan(x) arc tangent atan2(x,y) +exponential exp(x) square root sqrt(x) +natural log log(x) common log log10(x) +modulo mod(x) minimum min(x,y) +row number row() maximum max(x,y) +nearest integer nint(x) convert to integer int(x) +convert to real real(x) convert to string str(x) +.fi + +The row number function returns an integer value corresponding to the +row number in the table. The date difference function returns a real +value corresponding to the Julian date of the first argument minus the +Julian date of the second argument; the arguments to the data function +must be in CDBS date format: i.e., character strings of the form +YYYYMMDD:HHMMSSCC. Any field after the colon is optional. The last +date field (CC) is hundreths of a second. + +One concept in most databases and in STSDAS tables is the concept of a +null value: a value which indicates that the element is unknown or +non-existent. An element in an STSDAS table is null if it is INDEF in a +numeric column or a zero length string in a text column. Evaluating +expressions involving nulls requires a three valued logic: true, +false, and unknown. Any arithmetic operation on a null element should +return another null and any comparison operation should return an +unknown. Unfortunately, tselect does not implement a true three +valued logic correctly. The code instead evaluates any expression +containing a null element as unknown. Since tselect only returns rows +for which the expression is true, all such rows are excluded from the +output of tselect. This is usually right, but sometimes wrong, as in +the case where two comparisons are joined by an or and one evaluates +to true and the other evaluates to unknown. It also sometimes returns +nonintuitive results, as when checking that a column is not equal to +INDEF. +.ih +PARAMETERS +.ls intable [file name template] +Table(s) from which rows are copied. If input is redirected, this +parameter will ignored and input will be read from STDIN instead. +.le +.ls outtable [file name template] +The new table(s) containing the copied rows. +If more than one input table was used, then the number of output +tables must equal the number of input tables. +.le +.ls expr [string] +The boolean expression which determines which rows are copied to the new +table. The expression may be placed in a list file and the name of the file +passed to this parameter (preceded by the "@" character). +.le +.ih +EXAMPLES +1. Extract all binary stars brighter than fifth magnitude from a catalog: + +.nf +tt> tselect starcat.tab binary.tab "binary && mag <= 5." +.fi + +2. Create a new set of spectra where all measurements with errors greater +than ten percent are excluded. Use file name editing to create new tables +with the extension ".tbl" instead of ".tab": + +.nf +tt> tselect *.tab *.%tab%tbl% "ERROR / (FLUX + .001) < .1" +.fi + +3. Create a table of engineering parameters whose names begin with a digit: + +.nf +tt> tselect datalog.tab sublog.tab "name ?= '^[0-9]'" +.fi + +4. Return all observations in a schedule for the day of Dec 31, 1989: + +.nf +tt> tselect schedule.tab week.tab "abs(delta(date,'19891231:12'))<.5" +.fi +.ih +BUGS +Column names must be set off from operators by blanks in the +expression so that they can be correctly parsed by the expression +evaluator. Expressions involving nulls may evaluate incorrectly, see +above for a discussion. +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +tproject, tjoin, tproduct + +Type "help tables opt=sys" for a higher-level description of the 'tables' +package. +.endhelp diff --git a/pkg/utilities/nttools/doc/tsort.hlp b/pkg/utilities/nttools/doc/tsort.hlp new file mode 100644 index 00000000..f07605e4 --- /dev/null +++ b/pkg/utilities/nttools/doc/tsort.hlp @@ -0,0 +1,84 @@ +.help tsort Dec90 tables +.ih +NAME +tsort -- Sort a table on one or more columns. +.ih +USAGE +tsort table columns +.ih +DESCRIPTION +This task sorts an STSDAS-format table. The sort is done in place, so if you want +to keep a copy of the unsorted table, you should copy it with the 'tcopy' +task before you +do the sort. The column, or columns, on which to sort are specified +using the parameter +'columns', which is a list of column names, or column name templates, +separated by +commas. The most significant column name is the first in the list---the +column whose values are sorted; subsequent +columns are used only to break ties. There are two flags, 'ascend' and +'casesens'. The 'ascend' parameter determines whether the sort is done +in ascending or descending order, if +'ascend = yes', the first row in the output table holds the lowest value (if +the sorted column is numeric) or the first string in alphabetic order (if the +sorted column is a character string). If 'casesens = yes', upper +case characters +precede lower case characters. Otherwise, case is not significant +in determining the sort order. When sorting a boolean column, "no" precedes +"yes". Null table elements are always last in the sort, regardless +of the value of 'ascend'. +.ih +PARAMETERS +.ls table [file name template] +Name of the table, or tables, to be sorted in-place. +All tables are sorted on the same column or columns; if more than one table +is specified all tables must have the column(s) specified by the 'columns' +parameter. +.le +.ls columns [string] +Column name or column name template describing columns on which sort will +be performed. A column name template consists of a list of +column names, or column patterns containing wildcard characters. +Individual column names, or templates, are separated by commas or white space. +The list of columns can be placed in a file and the name of the +file passed to 'columns' (preceded by a +"@" character). +.le +.ls (ascend = yes) [boolean] +Sort the table in ascending order? If you want the table sorted in descending +order, set 'ascend = no'. +.le +.ls (casesens = yes) [boolean] +Are sorts on character columns to be case sensitive? If 'casesens = yes', +upper case letters will precede lower case letters. If 'casesens = no', +case is ignored by the sort operation. +.ls +.ih +EXAMPLES +1. Sort a table of star positions by right ascension and declination: + +.nf +tt> tsort starcat.tab ra,dec +.fi + +2. Sort a phone list. Make the sort case insensitive: + +.nf +tt> tsort phone.tab lname,fname case- +.fi + +3. Sort a star catalog so that all binary stars (i.e., a boolean column +named 'binary') are first: + +.nf +tt> tsort starcat.tab binary asc- +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +tcopy +.endhelp diff --git a/pkg/utilities/nttools/doc/tstat.hlp b/pkg/utilities/nttools/doc/tstat.hlp new file mode 100644 index 00000000..709ddd57 --- /dev/null +++ b/pkg/utilities/nttools/doc/tstat.hlp @@ -0,0 +1,225 @@ +.help tstat Jan2001 tables +.nj +.ih +NAME +tstat -- Get statistics for a table column. +.ih +USAGE +tstat intable column +.ih +DESCRIPTION +This task gets the mean, standard deviation, median, minimum and maximum +values for a table column. +The output will be written to cl parameters and may also be written either +to the standard output (STDOUT) or to a table. +When more than one table is specified as 'intable', the statistics are +determined for each table separately, not cumulatively. The values +in the cl parameters therefore refer to the last table in the list. + +If an input table contains only one column +(either in fact or due to the use of a column selector with the table name), +then the 'column' parameter is ignored, +and statistics are computed for that one column. +If 'intable' includes more than one table, +the 'column' parameter may be required for some tables +(those with more than one column) but not for others. + +The range of rows to use for statistics +may be restricted either by the 'rows' parameter +or by use of a row selector with the table name. +Both may be used, in which case 'rows' +is interpreted to mean selected row numbers, +rather than rows in the underlying table. +That is, the row selector with the table name is applied first, +then the 'rows' parameter is used to further restrict the rows. + +For a column that contains arrays, +this task reads all elements of all selected rows +and computes statistics on all those elements together. +Typical usage for array columns would be to specify just one row, +but any number of rows may be included, +limited only by memory. + +Lower and upper limits may be set using the parameters 'lowlim' and 'highlim' +such that table values outside that range are not used when computing +the statistics. +Either the lower or upper limit may be set individually. +If there are no values within the range specified +and within the range of rows given by the 'rows' parameter, +then the average, etc, will be printed as INDEF. + +For some tables, one can get statistics on the data in a row +by using 'tdump' and piping the output to 'tstat'. +See the examples for more information. +.ih +PARAMETERS +.ls intable [file name template] +A list of input tables. +Statistics will be obtained for one column, the same name in every table. +If the input is redirected, +this parameter need not be specified; +that is, if there's only one command-line argument, +it will be taken to be the column name. +.le +.ls column [string] +Column in input tables. +The statistics are gotten for the values in the column with this name. +If an input table contains only one column, +this parameter will be ignored, +and you will not even be prompted for a value. +If 'intable' includes more than one table with only one column, +the column name does not need to be the same in each of these tables. +For tables containing more than one column, +this parameter is required, +and the same column name will be used for each table in the list +that contains more than one column. +.le +.ls (outtable = "STDOUT") [string] +Output table, STDOUT, or null. +If 'outtable' is null ("") then the results will only be written to cl +parameters (see 'nrows', 'mean', 'stddev', 'vmin', 'vmax'). +If 'outtable' is "STDOUT" then the results will be written to +the standard output preceded by a header line (beginning with #) +that gives the name of the table and the name of the column. +If 'outtable' is not "STDOUT" and is not null then it is interpreted as +a table name (just one name), and the statistics for the input tables +will be written to separate rows of the output table. +If the table already exists, +the rows will be appended to what is already there. +The output column names are given by +the parameters 'n_tab', 'n_nam', 'n_nrows', etc. +.le +.ls (lowlim = INDEF) [real] +Values below this are ignored. +.le +.ls (highlim = INDEF) [real] +Values above this are ignored. +.le +.ls (rows = -) [string] +Range of rows to use for statistics. +The default "-" means that all rows are used. +See the help for RANGES in XTOOLS for a description of the syntax. +.le +.ls (n_tab = table) [string] +Column name for name of input table. +This and other parameters that begin with "n_" are only used if the output values are +written to a table. +.le +.ls (n_nam = column) [string] +Column name for name of input column. +This and other parameters that begin with "n_" are only used if the output values are +written to a table. +.le +.ls (n_nrows = nrows) [string] +Column name for number of good rows. +.le +.ls (n_mean = mean) [string] +Column name for mean. +.le +.ls (n_stddev = stddev) [string] +Column name for standard deviation. +.le +.ls (n_median = value) [string] +Column name for median. +.le +.ls (n_min = min) [string] +Column name for minimum. +.le +.ls (n_max = max) [string] +Column name for maximum. +.le +.ls (nrows) [integer] +The number of rows for which the column value was not INDEF and was +within the range 'lowlim' to 'highlim'. +This is a task output parameter. +.le +.ls (mean) [real] +Mean value (of the last table in the input list 'intable'). +This is a task output parameter. +.le +.ls (stddev) [real] +Standard deviation of the values (not of the mean). +This is a task output parameter. +.le +.ls (median) [real] +Median value. +This is a task output parameter. +.le +.ls (vmin) [real] +Minimum. +This is a task output parameter. +.le +.ls (vmax) [real] +Maximum. +This is a task output parameter. +.le +.ih +EXAMPLES +1. Get statistics on column "flux" in all tables, putting the output +(assuming outtable="STDOUT") in the ASCII file 'flux.lis': +.nf + + tt> tstat *.tab flux > flux.lis +.fi + +2. In order to get statistics on the data +in a row rather than a column, +you can use 'tdump' for one row +and specify pwidth to be so small that +each value will be printed on a separate line. +The output of 'tdump' will then be a one-column table +containing the row from the input table, +and 'tstat' can be run on that one-column table. +Since the input is redirected, we don't specify the table name. +Note also that in this case the input contains only one column, +so we don't specify the column name either. +In this example, we get statistics on row 17 of "bs.fits": +.nf + + tt> tdump bs.fits cdfile="" pfile="" \ + >>> row=17 pwidth=15 | tstat +.fi + +3. When the input is redirected and has multiple columns, +the command-line argument should be the column name to use, +not the table name. +The table name in this case will internally be set to "STDIN". +.nf + + tt> dir l+ | tstat c3 +.fi + +4. The statistics on column "flux" in 'hr465.tab' are put in parameters +'tstat.nrows', 'tstat.mean', etc., +and are not written to STDOUT or to a table. +We only include rows for which column V is no larger than 12. +.nf + + tt> tstat "hr465.tab[r:v=:12][c:flux]" outtable="" +.fi + +5. The output statistics are written to a table. The default column name +for the mean value is overridden: +.nf + + tt> tstat hr465.tab flux outtable=hr465s.tab n_mean="mean_flux" +.fi + +6. Get statistics on column "flux" in table 'hr465.tab', but only for +rows 17 through 116, row 271, and row 952: +.nf + + tt> tstat hr465.tab[c:flux] outtable="STDOUT" row="17-116,271,952" +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +thistogram, ranges + +Type "help tables opt=sys" for a higher-level description of the 'tables' +package. +.endhelp diff --git a/pkg/utilities/nttools/doc/ttranspose.hlp b/pkg/utilities/nttools/doc/ttranspose.hlp new file mode 100644 index 00000000..9a1a7c25 --- /dev/null +++ b/pkg/utilities/nttools/doc/ttranspose.hlp @@ -0,0 +1,139 @@ +.help ttranspose Nov94 tables +.nj +.ih +NAME +ttranspose -- Transpose or flip a table. +.ih +USAGE +ttranspose intable outtable action +.ih +DESCRIPTION +This task can be used to transpose a table +so that input rows become output columns +and input columns become output rows. +Another option is to flip the table horizontally, +that is, the first input column is the last output column. +Finally, the table can be flipped vertically, +i.e., the first input row is the last output row. +Any combination of these operations may be performed. + +If the table is actually transposed +(rather than just flipped horizontally and/or vertically), +the data types of all input columns must be the same. +In addition, if the columns contain arrays rather than scalars, +all the array lengths must be the same. +The data type and array size will be preserved in the output table, +but the column names of the output table will be "c1", "c2", "c3", etc, +with default print format and null units. +Actually, some mixing of data types is permitted. +If some columns are type real and others are double precision, +the output data type will be double precision. +Similarly, short integers will be promoted to integers. +Boolean columns can be mixed with any other data type; +for numeric columns, yes becomes 1 and no becomes 0. +When the columns in the input table are character strings, +different maximum string lengths are permitted, +and the output length will be the maximum of the input lengths. +The restrictions on data type are not imposed on text tables, +which can contain mixed integer, double precision and text columns. + +If the table is only flipped but not transposed, +the above restrictions on data type do not apply, +and the column names, units and print formats will be preserved. +Note that an operation such as "tht" +(which happens to be equivalent to "v") +does not actually transpose the table, +so the data types of the columns need not all be the same. + +The 'tstat' task gives statistics for the values in a column, +so one application of 'ttranspose' is to get statistics on +the values in a row by first transposing the table and then running 'tstat'. + +Text tables with too many rows cannot be transposed +due to the limit of 1024 on the length of each row of a text table. +.ih +PARAMETERS +.ls intable [file name template] +The list of input table names. +.le +.ls outtable [file name template] +The list of output table names. +There must be the same number of input and output names. +If the output is to be written to the standard output, however, +you can use outtable = "STDOUT" even if there several input tables. +.le +.ls action = "t" [string] +This is a string made up of the letters "t", "h", and "v" +which specify the operations to perform on the tables. +"t" means transpose (input rows become output columns), +"h" means flip horizontally (reverse the order of the columns), +and "v" means flip vertically (reverse the order of the rows). +The operations are performed in the order given from left to right. +Any combination of "t", "h", and "v" may be used, +in any order, and the letters may be repeated. + +Operations such as "tt", "hh" or "vv" are valid, +and they result in a simple copy of input to output. + +The symbols "/", "-" and "|" are equivalent to +the letters "t", "h" and "v" respectively. +.le +.ls verbose = yes [boolean] +Print the names of the tables as they are processed? +.le +.ih +EXAMPLES +1. The input is the text file "in", +and the output is to be displayed on the screen. +Each of the three operations ("t", "h", "v") +and some combinations are illustrated. + +.nf + tt> type in + one two three + four five six + seven eight nine + ten eleven twelve + + tt> ttranspose in STDOUT t + in --> STDOUT + one four seven ten + two five eight eleven + three six nine twelve + + tt> ttranspose in STDOUT h + in --> STDOUT + three two one + six five four + nine eight seven + twelve eleven ten + + tt> ttranspose in STDOUT v + in --> STDOUT + ten eleven twelve + seven eight nine + four five six + one two three + + tt> ttranspose in STDOUT hv + in --> STDOUT + twelve eleven ten + nine eight seven + six five four + three two one + + tt> ttranspose in STDOUT th + in --> STDOUT + ten seven four one + eleven eight five two + twelve nine six three +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +Type "help ttools opt=sys" for a description of the 'tables' package. +.endhelp diff --git a/pkg/utilities/nttools/doc/tunits.hlp b/pkg/utilities/nttools/doc/tunits.hlp new file mode 100644 index 00000000..553ebb6e --- /dev/null +++ b/pkg/utilities/nttools/doc/tunits.hlp @@ -0,0 +1,143 @@ +.help tunits Jan99 ttools +.ih +NAME +tunits -- Convert a table column from one set of units to another +.ih +USAGE +tunits table column newunits +.ih +DESCRIPTION +Tunits converts a column in a table from one set of units to +another. It supports both scalar and array columns. You supply the +table and column name and the new units you want the column to be +in. Optionally, you can apply the current column units if the units +string stored in the table is missing or incorrect. Tunits only +supports multiplicative conversions, conversions that involve additive +changes, like Kelvin to Celsius, are not supported. Unit names and +conversions are read from two tables. You can copy these tables and +edit them if you want to add new conversions. + +You can find out the current units for a table column by running +tlcol. If a units conversion is not supported by this task and you +know the conversion formula, you can run tcalc. + +Tunits must parse the unit strings you pass it, which requires that +they follow a certain set of rules. Units can be a simple units name, +such as ergs, or a units name raised to a power, such as meters^2, or +the product or quotient of units names raised to a power, such as +feet/sec or gm*cm/s^2. If two units names are next to each other +without any operator between them, a multiplication is assumed. If a +units name is followed by a number, the units name is assumed to be +raised to that power. + +Powers can also be specified by preceding the unit name with the +string "square", "sq", "cubic", or "cu". For example, "square meter" +is equivalent to "meter^2". + +The operators recognized are: + +.nf +division / or per +multiplication * +exponentiation ^ or ** +.fi + +Division has the lowest priority and exponentiation the highest. This +means ergs/sec*angstrom is interpreted as ergs/(sec*angstrom) and not +(ergs/sec)*angstrom, as it would be in most computer languages. The +default priority can be changed by changed by grouping terms with +parentheses. + +Each set of units can have several synonymous names. These names are +listed in the abbreviations table. Case is not significant in names +and regular plurals (made by adding an "s") are converted to the +singular. Names should contain only alphabetic characters. Blanks, +underscores and digits are not allowed. + +The conversions supported by this task are read from the units +conversion table. The table lists the old and new units and a +conversion factor. Only one conversion is allowed for each set of +units. + +.ih +PARAMETERS +.ls table [file] +The name of the table the conversion is applied to. +.le +.ls column [string] +The column to be converted. Both scalar and array columns are +supported. +.le +.ls newunits [string] +The new set of units for the column. The format of this parameter is +described above. This task writes the new units to the units field in +the table column. +.le +.ls (oldunits = " ") [string] +The units that the table column is currently in. If the value of this +parameter is blank, the units will be read from the table. +.le +.ls (abrevtab = "ttools$tunits/abrev.tab") [file] +A table of alternate names for each unit. This table contains two +columns. The first column is the name of the units and the second +column is the standard abbreviation. Because the default table is an +ascii file, columns are read positionally and not by column names + +Many units have more than one name or abbreviation. Using a standard +abbreviation allows units to be converted to a standard form, which +simplifies calculations. The standard abbreviation is used internally +when computing the conversion factor. Case is not significant in names +and regular plurals (made by adding an "s") are converted to the +singular before looking them up in the table. Names should contain +only alphabetic characters. Blanks, underscores and digits are not +allowed. + +The name of this table is a parameter to allow you to create your own +table of standard abbreviations, with additional units. +.le +.ls (unittab = "ttools$tunits/units.tab") [file] +A table of conversion factors from one set of units into another. +This table contains four columns. The first is the conversion factor, +a double precision number. The second is the units the task tries to +convert from. The third column is the units the task tries to convert +to. The fourth column is contains the boolean variable swap, explained +a little later. + +The table is interpreted as "There are in a ." +For example, "There are 100 centimeters in a meter." The last column, +swap, does not change the sense of the sentence but does change the +direction that the conversion is applied, For example, "60 seconds in +a minute" is actually a conversion from minutes to seconds because +swap is yes. Unit conversions should set swap to yes when the desired +conversion is not an exact value, but its inverse is. Only one +conversion is allowed per unit, which simplifies the program logic +considerably. Conversions should be chosen so that they ultimately +resolve to MKS units. To prevent endless loops conversions from the +fundamental units of MKS are checked for and forbidden. However, the +program does not check for other loops, so be careful when adding new +conversions! + +As in the case of the abbreviation table, the table name is a +parameter to allow you to create your own table with additional unit +conversions. +.le +.ls (verbose = no) [bool] +If you set this parameter to yes, the task will print a message to +STDERR for each units conversion utilized in computing the conversion +factor. +.le +.ih +EXAMPLES +Convert watts to ergs per second. Print the diagnostic messages: + +.nf +tt> tunits source.tab power "ergs/sec" old=watts verb+ +.fi +.ih +REFERENCES +This task was written by Bernie Simon +.ih +SEE ALSO +tlcol, tcalc + +.endhelp diff --git a/pkg/utilities/nttools/doc/tupar.hlp b/pkg/utilities/nttools/doc/tupar.hlp new file mode 100644 index 00000000..3c8d99b3 --- /dev/null +++ b/pkg/utilities/nttools/doc/tupar.hlp @@ -0,0 +1,365 @@ +.help tupar Jun97 tables +.nj +.ih +NAME +tupar -- Edit table header parameters. +.ih +USAGE +tupar table +.ih +DESCRIPTION +This task is an interactive editor that allows the user to modify table +header parameters. +Prompts are written to STDERR rather than +STDOUT so that STDOUT can be redirected to a file. +If STDERR is redirected, no prompts will appear. +Prompting is also turned off if the input is redirected from a file. + +The table to be edited is copied to a temporary table +in the same directory as the original table +(or in tmp$ if the first copy attempt fails), +and the changes are made to that copy. +When you exit 'tupar', +the copy is renamed back to the name of the original table. +If you quit rather than exit, +then the copy is deleted, so the original table will remain unchanged. + +The prompt ":" is used by the task when it is waiting for user input. +At this prompt the user can enter any editor command. +The "e" command (or end of file, e.g. Control-Z) will exit the editor. +The following commands are available: e, q, g, p, d, r, k, t, l. +These commands are interpreted as exit, quit (without saving changes), +get, put, delete, replace, change keyword name, type, and list respectively. +Each of these commands is described in detail below: + +The exit command, specified by "e" or end of file, +will close the file--saving all changes, +and open the next file if more than one file was specified +for the 'table' input parameter. + +The quit command is similar to exit except that changes that were made +to the header parameters will not take effect, +unless 'inplace = yes'. +If changes were made to the table header +you will be prompted for confirmation +unless the command was given followed by "!"; +for example, "q!" or "quit!". + +The type command, specified by "t", and the list command, +specified by "l", +both display header parameters---one header per line of output. +The difference between the two commands is that list will show the parameter +number and type will not. +Entering the command "t" or "l" will produce +a listing of all header parameters. +Optionally, an integer may follow +the command indicating that only a particular parameter is to be displayed. +Two integers following the command indicate a range of parameters. +If a number is specified that is beyond the range of valid headers, +an error message will be displayed. +The output consists of the name of the header parameter, +its data type (indicated by a single letter, +"r" for real, "b" for boolean, "i" for integer, or "d" for double), +and its current value. +If the keyword has an associated comment, +the comment will be displayed following the value. +The following are examples of valid syntax for listing header parameters: +.nf +t +l +t 3 +l 300 310 +.fi + +The get command, indicated by "g", will look for a specific keyword and +display its current value. +Optionally, the data type can be specified +using the letter "r" for real, "i" for integer, "d" for double, or +"b" for boolean. +If no data type is specified, then the type is assumed to be text. +If the data type is specified, +the type immediately follows the "g" command; +for example, typing the command "gd X" will get the value +contained in the header keyword "X" and display it as a double-precision +real value. +If "X" does not exist, no output will be produced. +If the keyword has an associated comment, +the get command displays the comment following the value; +a text string value will be enclosed in quotes +to distinguish the value from the comment. +Examples of valid syntax follow: +.nf +g history +gd coeff0 +gi numpts +.fi + +The put command, specified by "p", will either replace the value of an +existing parameter, +or it will create a new parameter if the specified parameter is not found. +The "p" command is followed on the command line by a keyword +name and the parameter value. +A comment may optionally follow the value. +The "p" command itself should +be followed by a single letter type specifier, "i" for integer, +"r" for real, "d" for double, or "b" for boolean. +If no type is specified, then the data type is assumed to be text. +In order to specify a comment with a parameter of type text, +the parameter value must be enclosed in quotes +in order to distinguish it from the comment. (Keyword names +HISTORY and COMMENT are already comments, +and further comments cannot be added to them.) +Examples of valid put command syntax follow: +.nf +p comment Created for testing. +gd coeff0 +pd coeff0 3.141592653589793 +pi ncoeff 7 number of coefficients +pt fittype chebychev +pt fittype "chebychev" type of fit that these coefficients represent +.fi + +The replace command, specified by "r", works much like the put command +described above; however, it will prompt the user for confirmation before +actually changing any values in the table. +A parameter can be specified by name or by number. +The "r" command will not change a keyword name or a data type, +whereas the "p" command can. +After the command is entered, +the current value of the keyword is displayed and +the editor waits for a new value to be entered by the user. +Pressing the return key indicates that no change is to be made. +Pressing the space bar will blank the current value. +You will then be prompted for +confirmation unless the command was issued as "r!" or the input was +redirected from a file. +The default action is given by the 'delete_default' parameter. + +A range of contiguous parameters can be replaced at one time by giving +the names or numbers of the first and last parameters to be replaced. +This can involve a lot of prompting for confirmation, +especially if several tables are being edited with 'same=yes'. +In this context, "contiguous" means adjacent in the table header. +Thus, when replacing a range by name, +it is not the parameters that fall alphabetically within the limits +that will be replaced +but rather the parameters that are numerically within the limits. +When editing a list of tables with 'same=yes', +the same replacement string is used for each table. +Thus it is essential that there be the same number of parameters in +the range in all tables being edited. +When no replacement value is given (i.e., just hit the return key), +then the current keyword value is not changed, +either in the first table or in subsequent tables. + +Sample replace commands follow: +.nf +r coeff0 +r 17 +r! 17 +r junk dummy +r junk 12 +r 5 12 +.fi + +The delete command, specified by "d", will delete a header parameter by +either name or number. +The editor prompts for confirmation of delete, +unless input is redirected from a file. +The default action is given by the 'delete_default' parameter. +If you do not want to be prompted for confirmation, enter the command as "d!". +If you want to delete a history or comment record other than the first, +you can identify the parameter by number rather than name. + +A range of contiguous parameters can be deleted at one time by giving +the names or numbers of the first and last parameters to be deleted. +As with replacing a range of parameters, +a contiguous block of parameters will be deleted. + +Examples of valid delete commands follow: +.nf +d testflag +d 17 +d! 17 +d junk dummy +d junk 12 +d 5 12 +.fi + +The "k" command changes the name of a keyword +without changing the data type, value, or comment. +Give the current and new keyword names following the "k". +Note that keywords are limited to eight characters. +If the name of a COMMENT or HISTORY keyword is changed, +only the first occurrence of that keyword will be changed. + +Examples of valid change keyword commands follow: +.nf +k history comment +k dummy test +.fi +.ih +PARAMETERS +.ls table [file name template] +A table name or list of table names whose header parameters are to be edited. +Unless 'inplace = yes', +each table will be copied (one at a time) to a temporary table, +and changes are made to the copy until you exit. +This can cause problems if there is not enough disk space for the copy; +however, the 'inplace' parameter can +be set to "yes" so that the tables are opened in-place. +.le +.ls (same = no) [boolean] +Apply the same set of instructions to all tables? + +This is only relevant when more than one table is being edited. +If 'same = no', instructions are processed separately for each table, +with the "e" command used to end processing of a table and open +the next table. + +If 'same = yes', the same instruction set is applied to all tables. +These instructions will be read from STDIN (which may be redirected) +and saved in a local buffer while the first table in the list is open. +For each subsequent table the instructions will be read from the local buffer. +Caution is advised when deleting or replacing parameters, especially by +number; remember that prompting for confirmation is turned off if the +input is redirected or if the instruction is given as "d!" or "r!". + +If 'same = yes' and you quit (rather than exit) from editing the first table, +the behavior of the task depends on whether changes were made before quitting. +If changes were made then the task aborts immediately +without opening the other tables in the input list. +If no change was made then the other tables are processed. +The idea is to allow "g", "t", and "l" commands +and still be able to quit rather than exit, +since nothing was modified. +If changes were made but you quit, +that's interpreted as trying to recover from an error, +so we don't change the first table and we don't continue. +.le +.ls (verbose = yes) [boolean] +Display the name of each table when it is opened? + +If STDOUT is redirected +then these file names will be written to STDERR as well as to STDOUT. +.le +.ls (readonly = no) [boolean] +Prevent changes from being made to the file? + +If 'readonly = yes', then the +table is opened with read only access. This is useful for viewing the +contents of the table while at the same time preventing changes from +being made to it. (Only the "g", "t", and "l" commands are useful in +read only mode). +.le +.ls (inplace = no) [boolean] +Edit the original table in-place? + +By default a copy of the original table is made, +either in the same directory or in tmp$. +This makes it possible to quit without saving changes. +If the table is large, however, +it may be undesirable to make a copy, +so the 'inplace' parameter gives you the option +of editing the original table. +In this case, however, it will not be possible to quit without saving changes. +.le +.ls (quit_default = no) [boolean] +The value of this parameter is the default response to the prompt +for confirmation if you give the quit command. +.le +.ls (delete_default = yes) [boolean] +The value of this parameter is the default response to the prompt +for confirmation for the delete and replace commands. +.le +.ls go_ahead [boolean] +The user does not set this explicitly. +It is the parameter which is actually gotten in response to a prompt. +.le +.ih +EXAMPLES +1. This example reads all history records from all tables in the default +directory and writes them to 'history.lis'. +.nf + +tt> tupar *.tab same=yes verbose=no readonly=yes >history.lis + (The task writes a ":" prompt and waits for input.) +:g history +:q +tt> +.fi + +2. This example illustrates the use of each of the commands when editing +parameters in one table. This kind of interactive use of the task +would not be appropriate when operating on a list of tables unless +the 'same' parameter is set to "no". +.nf + +tt> tupar junk + (The task writes the table name and a ":" prompt and waits for input.) +junk.lis +:g garvage + (The keyword was not found, so nothing was displayed.) +:g garbage +GARBAGE = 3.1416926535 +:pd garbage 3.1415926535 +:p comment yet another comment +:t +GARBAGE d 3.1415926535 +COMMENT t This is the first comment. +PI t 3.1415926535 not an accurate value +COMMENT t yet another comment +:l 3 999 + 3 PI t '3.1415926535' not an accurate value + 4 COMMENT t yet another comment +:g pi +PI = '3.1415926535' not an accurate value +:gd pi +PI = 3.1415926535 not an accurate value +:pd pi 3.14159265358979323846 a more accurate value +:l + 1 GARBAGE d 3.1415926535 + 2 COMMENT t This is the first comment. + 3 PI d 3.141592653589793 a more accurate value + 4 COMMENT t yet another comment +:d garbage +The following parameter is to be deleted: +GARBAGE d 3.1415926535 + ... OK to delete ? (yes): (user hits return) +:d comment +The following parameter is to be deleted: +COMMENT t This is the first comment. + ... OK to delete ? (yes): n (user types n) +:l 4 +parameter out of range; max is 3 +:d 3 +The following parameter is to be deleted: +COMMENT t yet another comment + ... OK to delete ? (yes): (user hits return) +:t +COMMENT t This is the first comment. +PI d 3.141592653589793 a more accurate value +:r 1 +keyword COMMENT, type t; give replacement value: +This is the first comment. (TUPAR writes this & waits) +this is a comment (this line entered by user) +Current parameter and its replacement are: +COMMENT t This is the first comment. +COMMENT t this is a comment + ... OK to replace ? (yes): n (user types n) +no action taken +:q +tt> +.fi +.ih +BUGS +.ih +REFERENCES +This task was written by Phil Hodge. +.ih +SEE ALSO +tprint, tdump, tedit + +Type "help tables opt=sys" for a higher-level description of the 'tables' +package. +.endhelp diff --git a/pkg/utilities/nttools/doc/wcspars.hlp b/pkg/utilities/nttools/doc/wcspars.hlp new file mode 100644 index 00000000..12e2dae1 --- /dev/null +++ b/pkg/utilities/nttools/doc/wcspars.hlp @@ -0,0 +1,184 @@ +.help wcspars Jul93 tables +.ih +NAME +wcspars -- Edit the parameter set that defines a world coordinate +system. +.ih +USAGE +wcspars +.ih +DESCRIPTION +The parameters in this pset are used to define a simple world +coordinate system (WCS) for use by various tasks that require such +information, such as 'wcslab' or 'siaper'. + +Note that this is a pset, not an executable task; it defines a set of +parameters used by other tasks. Invoking the pset by name runs 'eparm' +on the parameter set, allowing the user to modify the parameters. +Alternatively, the parameters may be modified on the command linne by +specifying the pset name and parameter name. For example, you can +type 'wcspars.ctype="ra---tan"'. Parameters may also be edited by +using 'eparam' on the calling task. An example is the task 'wcslab'. By +typing 'eparam wcslab', positioning the cursor on the parameter +'wcspars', and type ':e', the user would then be editing the parameters +in this pset. + +A WCS is used to transform coordinates from one system to another. +For example, for converting from pixel coordinates to celestial +coordinates. To perform such transformations, certain information is +required, such as the type of system. Below is a brief description of +the IRAF implementation of WCS and how to the parameters in this pset +to define a WCS. + +The IRAF implementation defines a transformation from some "logical" +system (e.g., pixel space) to some "world" system (e.g., RA and DEC). +The first piece of information required is the type of world system is +being dealt with. At the moment, there are two general systems +defined: 'linear' which provides a linear mapping from the logical to +world systems, and the celestial projects which provide a mapping from +pixel space to celestial coordinate space. The parameters 'crtype1' and +'ctype2' are used to specify the type of system. If a linear system is +desired, both parameters will have the value "linear". If the TANGENT +plane projection is desired where the first axis represents RA and the +second represents DEC, then the parameters would have the values, +'ctype1 = "ra---tan"', 'ctype2 = "dec--tan"'. There are also a sine +projection (SIN) and arc (ARC) projection provided. + +The scale factor and rotation between the two systems are defined by +a coordinate transformation (CD) matrix. Through matrix +multiplication, the logical coordinates are multiplied by the CD +matrix to produce the world coordinates. The matrix is represented in +the parameters as follows: +.nf + + |---------------| + | cd1_1 cd1_2 | + | | + | cd2_1 cd2_2 | + |---------------| + +.fi +To construct the CD matrix, the following definitions may be used: +.nf + + cd1_1 = Sx * cos(PA) + cd1_2 = -Sy * sin(PA) + cd2_1 = Sx * sin(PA) + cd2_2 = Sy * cos(PA) + +.fi +where Sx and Sy are the scale factors from the logical to world +systems and PA is the angle of rotation between the two systems +(positive rotation is counterclockwise). + +There is a special case for the transformation to RA and DEC. Since RA +increases "to the left", opposite of standard convention, -1 needs +to be multiplied through the CD matrix for the first axis. This +results in the formulas below: +.nf + + cd1_1 = -Sx * cos(PA) + cd1_2 = Sy * sin(PA) + cd2_1 = Sx * sin(PA) + cd2_2 = Sy * cos(PA) + +.fi + +Finally, the origins of the logical and world systems must be defined. +The parameters 'crpix1' and 'crpix2' define the coordinate in the logical +space that corresponds to the coordinate in world space defined by the +parameters 'crval1' and 'crval2'. Quite simply, the coordinate (crpix1, +crpix2) in the logical space, when transformed to the world space, +would be the coordinate (crval1, crval2). + +The last set of parameters, 'log_x1', 'log_x2', 'log_y1', 'log_y2', define a +region in the logical space over which the transformation is valid. +.ih +PARAMETERS +.ls (crtype1 = "linear") [string] +The system type of the first axis. Possible values depend on what +transformations have been implemented in the IRAF system. To date the +following values represent valid transformations: linear, xxx--tan, +xxx-sin, xxx-arc (where xxx is either "ra-" or "dec"). Note that if any +of the celestial transformations are used, the "ra" must appear in one +of 'crtype1' or 'crtype2' and "dec" must appear in the other parameter. +.le +.ls (crtype2 = "linear") [string] +The system type of the second axis. See above for values. +.le +.ls (crpix1 = 0.) [real] +The X coordinate of the reference point in logical space that +corresponds to the reference point in the world space. +.le +.ls (crpix2 = 0.) [real] +The Y coordinate of the reference point in logical space that +corresponds to the reference point in the world space. +.le +.ls (crval1 = 0.) [real] +The X coordinate of the reference point in world space that +corresponds to the reference point in the logical space. +.le +.ls (crval2 = 0.) [real] +The Y coordinate of the reference point in world space that +corresponds to the reference point in the logical space. +.le +.ls (cd1_1 = 1.) [real] +Entry in the CD matrix. Usually has the value , +or for RA and DEC systems, <-xscale * cos(angle)>. +.le +.ls (cd1_2 = 0.) [real] +Entry in the CD matrix. Usually has the value <-yscale * sin(angle)>, +or for RA and DEC systems, . +.le +.ls (cd2_1 = 0.) [real] +Entry in the CD matrix. Usually has the value . +.le +.ls (cd2_2 = 1.) [real] +Entry in the CD matrix. Usually has the value . +.le +.ls (log_x1 = 0.) [real] +The lower X axis extent in logical space over which the transformation +is valid. +.le +.ls (log_x2 = 0.) [real] +The upper X axis extent in logical space over which the transformation +is valid. +.le +.ls (log_y1 = 0.) [real] +The lower Y axis extent in logical space over which the transformation +is valid. +.le +.ls (log_y2 = 0.) [real] +The upper Y axis extent in logical space over which the transformation +is valid. +.le +.ih +EXAMPLES +1. The following example +is for an image that does not contain any WCS information. +The image is 512x512 pixels, where the pixels are approximately 1/10th +an arcsecond in size, whose center pixel is located at 9h 22m 30.5s +and -15o 5m 42s and is rotated 30 degrees towards the west: +.nf + + 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. + +.fi +.ih +BUGS +.ih +SEE ALSO +.endhelp diff --git a/pkg/utilities/nttools/doc/wlpars.hlp b/pkg/utilities/nttools/doc/wlpars.hlp new file mode 100644 index 00000000..08f987a9 --- /dev/null +++ b/pkg/utilities/nttools/doc/wlpars.hlp @@ -0,0 +1,440 @@ +.help wlpars Jul93 tables +.ih +NAME +wlpars -- Edit the parameter set that determines how WCS labeling +appears. +.ih +USAGE +wlpars +.ih +DESCRIPTION +These parameters determine the characteristics of plots that are +produced by the various tasks that use the World Coordinate System +(WCS) information from image data. Various +parameters can be set in 'wlpars', including those controlling +the appearance of features such as +major and minor tick marks, the use of grid lines, etc. + +Note that this is a pset, not an executable task; it defines a set of +parameters used by other tasks. Invoking the pset by name runs +`eparam' on the parameter set, allowing you to modify the +parameters. Alternatively, the parameters may be modified on the +command line by specifying the pset name and parameter name. For +example, the user can type "wlpars.major_grid=no" to not draw lines +for the major grid, but to include tick marks. +Parameters can also be edited by +using `eparam' on the calling task (e.g., by typing "eparam wcslab"), +in which case, `wlpars' will appear as one of the task parameters; the +`wlpars' parameters may then be edited by positioning the cursor on +the line containing the pset name and typing ":e". After editing the +pset parameters, press Control-Z to return to the main task parameter +menu. + +Below is a list of areas that explain in more detail what the +parameters in this pset accomplish. This explanation also occurs in +the help for 'wcslab'. + +.ls Axis Specification +For all linear transformations axis 1 and axis 2 specify which axis in +the image WCS 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 CELESTIAL plane projection WCSs. +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. + +.le +.ls Grid Drawing +There are two types of grid lines and tick marks, "major" and +"minor". The major grid lines and tick marks are the lines or ticks +that will be labeled. The minor grid lines or tick marks are plotted +between the major marks. Whether lines or tick marks are drawn is +determined by the boolean parameters 'major_grid' and 'minor_grid'. +If these are set to "yes", lines are drawn; if "no", +tick marks are drawn. How the lines +appear is controlled by the parameters 'major_line' and 'minor_line'. + +The spacing of minor marks is controlled by the parameters 'axis1_minor' +and 'axis2_minor'. 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 generally be an +hour and the major marks will appear at whole hours within the graph. +If the values chosen by 'wcslab' are unacceptable, the interval and range can +be modified by the parameters 'axis1_int', 'axis1_beg', +'axis1_end' for the 'axis 1', and 'axis2_int', 'axis2_beg', +and 'axis2_end' for 'axis 2'. All three parameters must be specified for +each axis in order for the new values to take affect + +.le +.ls 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 that +meets the following criteria: 1) +has no defined WCS, 2) has a linear WCS, and 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 that 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. If you don't like the labeling defaults, +the parameters, 'axis2_dir' and 'justify' can be modified +to control how the labeling is done. +The parameter 'axis2_dir' specifies along which axis 1 value the +axis 2 labels should be written; 'justify' specifies the side of +the value on which the label will 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 'graph_type' can be used to force 'wcslab' +to plot a graph of the type specified, although you may need to +change other 'wlpars' parameters to get good results. +For example, trying to plot a polar graph as +cartesian may producing a strange looking graph. +.le +.ls 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 one 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 the task are unacceptable, the +parameters 'axis1_side' and 'axis2_side', 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. +.le +.ls 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 rotate 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 'full_label = yes'. This +forces every label to use the full specification. + +Finally, the parameter 'label_size' can be used to adjust the size of the +characters used in the axis labels. +.le +.ls Titles +A graph title may specified using the parameter 'title'. +If 'title = "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 'title_side' and 'title_size'. +Similarly the content, placement and size of the axis titles are +controlled by the parameters 'axis1_title', 'axis2_title', +'axis1_title_side', 'axis2_title_side', and +'axis_title_size'. +.le +.ls Interactive Cursor +'wcslab' provides a simple cursor readback capability for retrieving +coordinates of objects and saving them in a file. However, you should +also look at the tasks 'tvmark' and 'rimcursor' for more advance +functionality. + +The cursor allows the user to examine +coordinates of specific objects and to make a file containing a +list of coordinates. For graphic displays, the user has the full cursor +functionality described by 'gcur'. However, there are a few extra +commands provided for transforming cursor position to celestial +coordinates. While in cursor mode, striking most lower-case +characters will result in the celestial coordinates of the cursor +position to be displayed on the terminal. + +Coordinates can also be written to a file by +striking the lower-case 'm'. When 'm' is hit, an 'X' is placed on the +display, and the coordinates are written to a coordinate list file. +This file can be specified in two ways. If you just start hitting +'m', a file called '.coord.list' will be created. You can +specify a +different +file with the colon command ":open ". After opening the +file, any +new coordinates marked with the 'm' key are written to the +file. You can go through as many files as you like. If a file is +specified that already exists, an attempt is made to read the file. +If it contains coordinate values, those coordinate positions are +displayed as crosses in the window, and any new position marked +will be appended. + +Striking the '?' key will display help concerning these task-specific +commands. Striking the 'q' key will exit the task. +.le +.ls Output Formats +Currently, only one coordinate format is supported: all right +ascensions are output in HH:MM:SS (hours:minutes:seconds) format +and +all declinations are output in DD:MM:SS (degrees:minutes:seconds). If +parameters are changed, such as 'axis1_int', they should be +input in the same format. For the coordinate list files, the first +line of the file begins with the comment character, '#', and displays +the format used in the file. + +If the WCS is linear, then output will not be formatted in any special +way; i.e., no assumptions are made about units, etc. +.le +.ih +PARAMETERS +.ls (major_grid = yes) [boolean] +Draw a coordinate grid instead of tick marks at the position of the major +intervals? + +If set to "yes", lines of constant axis1 and axis2 values are drawn. +If set to "no", tick marks will be drawn instead. Major grid lines and +tick marks will be labeled with the appropriate axis values. +.le +.ls (minor_grid = no) [boolean] +Draw a coordinate grid instead of tick marks at the position of the +minor intervals? + +If set to "yes", lines of constant axis1 and axis2 values +are drawn between the major grid lines and tick +marks. If this is set to "no", tick +marks will be drawn instead. Minor grid lines and tick +marks are not labeled. +.le +.ls (dolabel = yes) [boolean] +Label the major grid lines or tick marks? +.le +.ls (remember = no) [boolean] +Modify the 'wlpars' parameter file when done? + +Setting this to "yes" allows parameters that may have been calculated +by the task to be written back to the parameter file. If set to "no", +the default, the parameter file is left untouched by the task. This is +useful if some slight modification is desired to produce a slightly +different graph. +.le +.ls (axis1_beg = "") [string] +The lowest value of axis 1 in world coordinates units at which a major +grid line or tick mark will be plotted. If set to null ('axis1_beg = +""'), 'wcslab' will compute this quantity. 'axis1_beg' will be +ignored if 'axis1_end' and 'axis1_int' are undefined. +.le +.ls (axis1_end = "") [string] +The highest value of axis 1 in world coordinate +units at which a major grid line or tick mark will be plotted. +If 'axis1_end = ""', the task will compute this quantity. +'axis1_end' will be ignored if 'axis1_beg' and 'axis1_int' are undefined. +.le +.ls (axis1_int = "") [string] +The interval in world coordinate units at which +major grid lines and 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 = "") [string] +The lowest value of axis 2 in world coordinates units +at which a major grid line or tick mark will be plotted. +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 = "") [string] +The highest value of axis 2 in world coordinate +units at which a major grid line or tick mark will be plotted. +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 = "") [string] +The interval in world coordinate units at which +major grid lines or 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") [string, allowed values: solid | +dotted | dashed | dotdash] + +The type of major grid lines to be plotted. +The permitted values are "solid", "dotted", "dashed", and "dotdash". +.le +.ls (major_tick = .03) [real] +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) [integer] +The number of minor grid lines or tick marks that will appear between major +grid lines or tick marks for axis 1. +.le +.ls (axis2_minor = 5) [integer] +The number of minor grid lines or tick marks that will appear between major +grid lines or tick marks for axis 2. +.le +.ls (minor_line = "dotted") [string, allowed values: solid | +dotted | dashed | dotdash] + +The type of minor grid lines to be plotted. +The permitted values are "solid", "dotted", "dashed", and "dotdash". +.le +.ls (minor_tick = .01) [real] +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) [boolean] +Do tick marks point into instead of away from the graph? +.le +.ls (axis1_side = "default") [string] +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") [string] +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 = "") [string] +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") [string] +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) [boolean] +Draw the labels outside the axes? + +Setting this to "yes", draws labels 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) [boolean] +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, with the rest +labeled in minutes or seconds, as appropriate. +.le +.ls (rotate = yes) [boolean] +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) [real] +The size of the characters used to draw the major grid line labels. +.le +.ls (title = "imtitle") [string] +The graph title. If 'title = "imtitle"', then a default title containing +the image name and title is created. +.le +.ls (axis1_title = "") [string] +The title for axis 1. By default no axis 1 title is drawn. +.le +.ls (axis2_title = "") [string] +The title for axis 2. By default no axis title will be written. +.le +.ls (title_side = "top") [string, allowed values: top | bottom | +left | right] + +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") [string, allowed values: default | +top | bottom | left | right] + +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") [string, allowed values: default | +top | bottom | left | right] + +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) [real] +The size of characters used to draw the title. +.le +.ls (axis_title_size = 1.0) [real] +The size of the characters used to draw the axis titles. +.le +.ls (linecolor = INDEF) [integer] +Color used for drawing lines and tick marks. If this is not specified, +the default color +for the graphics output device will be used. +.le +.ls (labelcolor = INDEF) [integer] +Color used to write axis labels. If not specified, the color for the lines +and tickmarks will be used. +.le +.ls (titlecolor = INDEF) [integer] +Color used to write the plot title. If not specified, the color for the +labels will be used. +.le +.ls (graph_type = "") [normal | polar | near_polar] +String indicating what type of graph will be drawn. If empty, the +default, the task will determine the type. +.le +.ls (coords) [gcur] +The graphics cursor. +.le +.ls (image_coord) [imcur] +The image display cursor. +.le +.ls (version = "16Jun92" ) [string] +The date the current software was installed. +.le +.ih +EXAMPLES +.ih +BUGS +.ih +SEE ALSO +wcslab, cursors, newcont +.endhelp diff --git a/pkg/utilities/nttools/gtedit.par b/pkg/utilities/nttools/gtedit.par new file mode 100644 index 00000000..6455ec5d --- /dev/null +++ b/pkg/utilities/nttools/gtedit.par @@ -0,0 +1,11 @@ +input,s,a,,,,"Name of the input table" +xcolumn,s,a,,,,"Name of column in input to use as X axis" +ycolumn,s,a,,,,"Name of column in input to use as Y axis" +device,s,h,"stdgraph",,,output device +commands,*gcur,h,"",,,graphics commands +inplace,b,h,no,,,"Edit the table in place?" +output,s,h,"",,,"Name of output table to contain edited output" +reject,s,h,"",,,"Name of output table for deleted entries" +columns,s,h,"",,,"Columns to edit in text mode" +insert,b,h,yes,,,"Begin editing in insert mode (text mode)" +gtpar,pset,h,,,,"Plot attributes" diff --git a/pkg/utilities/nttools/gtedit/gtdelete.x b/pkg/utilities/nttools/gtedit/gtdelete.x new file mode 100644 index 00000000..c09f6a96 --- /dev/null +++ b/pkg/utilities/nttools/gtedit/gtdelete.x @@ -0,0 +1,360 @@ +include +include +include + +define MSIZE 2.0 + +# GT_DELPT -- Mark a point as deleted + +procedure gt_delpt (gd, wx, wy, x, y, npix, deleted, undelete) + +pointer gd # Graphics descriptor +real wx # Cursor position +real wy # "" +real x[ARB] # Plotted data +real y[ARB] # Plotted data +int npix # # of pixels +int deleted[ARB] # Array of delete indicators +int undelete # Undelete flag + +int row, i +real r2min, r2, x0, y0 + +begin + # Search for the nearest point which has not been deleted + + row = 0 + r2min = MAX_REAL + + # Transform world cursor coordintes to NDC + call gctran (gd, wx, wy, wx, wy, 1, 0) + do i = 1 , npix { + if ((deleted[i] == YES && undelete == NO) || + (deleted[i] == NO && undelete == YES)) + next + + call gctran (gd, x[i], y[i], x0, y0, 1, 0) + if (x[i] < INDEFR && y[i] < INDEFR) + r2 = (wx - x0) ** 2 + (wy - y0) ** 2 + else + r2 = MAX_REAL + + if (r2 < r2min) { + r2min = r2 + row = i + } + } + + if (row != 0) { + # Mark row as being deleted + if (undelete == NO) { + # Plot X over point + call gscur (gd, x[row], y[row]) + call gseti (gd, G_PMLTYPE, GL_SOLID) + call gmark (gd, x[row], y[row], GM_CROSS, MSIZE, MSIZE) + deleted[row] = YES + } else { + deleted[row] = NO + call gscur (gd, x[row], y[row]) + call gseti (gd, G_PMLTYPE, GL_CLEAR) + call gmark (gd, x[row], y[row], GM_CROSS, MSIZE, MSIZE) + } + + } + +end + +# GT_DYGT -- Delete all point > input Y + +procedure gt_dygt (gd, wy, x, y, npix, deleted, undelete) + +pointer gd # Graphics descriptor +real wy # Cursor position +real x[ARB] # Plotted data +real y[ARB] # Plotted data +int npix # # of pixels +int deleted[ARB] # Array of delete indicators +int undelete + +int i + +begin + # Search for points with Y values > than the critical value + + do i = 1 , npix { + if ((deleted[i] == YES && undelete == NO) || + (deleted[i] == NO && undelete == YES)) + next + + if (y[i] > wy) { + if (undelete == NO) { + # Plot X over point + call gseti (gd, G_PMLTYPE, GL_SOLID) + call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE) + deleted[i] = YES + } else { + deleted[i] = NO + call gseti (gd, G_PMLTYPE, GL_CLEAR) + call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE) + } + } + } +end + +# GT_DYLT -- Delete all point < input Y + +procedure gt_dylt (gd, wy, x, y, npix, deleted, undelete) + +pointer gd # Graphics descriptor +real wy # Cursor position +real x[ARB] # Plotted data +real y[ARB] # Plotted data +int npix # # of pixels +int deleted[ARB] # Array of delete indicators +int undelete + +int i + +begin + # Search for points with Y values > than the critical value + + do i = 1 , npix { + if ((deleted[i] == YES && undelete == NO) || + (deleted[i] == NO && undelete == YES)) + next + + if (y[i] < wy) { + if (undelete == NO) { + deleted[i] = YES + # Plot X over point + call gseti (gd, G_PMLTYPE, GL_SOLID) + call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE) + } else { + deleted[i] = NO + call gseti (gd, G_PMLTYPE, GL_CLEAR) + call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE) + } + } + } +end + +# GT_DXGT -- Delete all point > input X + +procedure gt_dxgt (gd, wx, x, y, npix, deleted, undelete) + +pointer gd # Graphics descriptor +real wx # Cursor position +real x[ARB] # Plotted data +real y[ARB] # Plotted data +int npix # # of pixels +int deleted[ARB] # Array of delete indicators +int undelete + +int i + +begin + # Search for points with X values > than the critical value + + do i = 1 , npix { + if ((deleted[i] == YES && undelete == NO) || + (deleted[i] == NO && undelete == YES)) + next + + if (x[i] > wx) { + if (undelete == NO) { + deleted[i] = YES + # Plot X over point + call gseti (gd, G_PMLTYPE, GL_SOLID) + call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE) + } else { + deleted[i] = NO + call gseti (gd, G_PMLTYPE, GL_CLEAR) + call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE) + } + } + } +end + +# GT_DXLT -- Delete all point > input Y + +procedure gt_dxlt (gd, wx, x, y, npix, deleted, undelete) + +pointer gd # Graphics descriptor +real wx # Cursor position +real x[ARB] # Plotted data +real y[ARB] # Plotted data +int npix # # of pixels +int deleted[ARB] # Array of delete indicators +int undelete + +int i + +begin + # Search for points with X values < than the critical value + + do i = 1 , npix { + if ((deleted[i] == YES && undelete == NO) || + (deleted[i] == NO && undelete == YES)) + next + + if (x[i] < wx) { + if (undelete == NO) { + deleted[i] = YES + # Plot X over point + call gseti (gd, G_PMLTYPE, GL_SOLID) + call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE) + } else { + deleted[i] = NO + call gseti (gd, G_PMLTYPE, GL_CLEAR) + call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE) + } + } + } +end + +# GT_DBOX -- Delete all point in a box + +procedure gt_dbox (gd, npix, deleted, undelete, x, y, x1, y1, x2, y2) + +pointer gd # Graphics descriptor +int npix # # of pixels +int deleted[ARB] # Array of delete indicators +int undelete +real x[ARB] # Plotted data +real y[ARB] # Plotted data +real x1, y1, x2, y2 # Corners of the box + +int i +real temp + +begin + # Make sure the points are in the correct order + if (y2 < y1) { + temp = y1 + y1 = y2 + y2 = temp + } + if (x2 < x1) { + temp = x1 + x1 = x2 + x2 = temp + } + # Search for points within the box + do i = 1 , npix { + if ((deleted[i] == YES && undelete == NO) || + (deleted[i] == NO && undelete == YES)) + next + + if (x[i] <= x2 && x[i] >= x1) { + if (y[i] <= y2 && y[i] >= y1) { + if (undelete == NO) { + deleted[i] = YES + # Plot X over point + call gseti (gd, G_PMLTYPE, GL_SOLID) + call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE) + } else { + deleted[i] = NO + call gseti (gd, G_PMLTYPE, GL_CLEAR) + call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE) + } + } + } + } +end + +# GT_DSEG -- Delete all point on one side of a line segment + +procedure gt_dseg (gd, npix, deleted, undelete, x, y, x1, y1, x2, y2, x0, y0) + +pointer gd # Graphics descriptor +int npix # # of pixels +int deleted[ARB] # Array of delete indicators +int undelete +real x[ARB] # Plotted data +real y[ARB] # Plotted data +real x1, y1, x2, y2 # Corners of the box +real x0, y0, slope, inter, temp + +int i, lessthan + +begin + # Make sure the points are in the correct order + if (y2 < y1) { + temp = y1 + y1 = y2 + y2 = temp + } + if (x2 < x1) { + temp = x1 + x1 = x2 + x2 = temp + } + + # Calculate slope and intercept + slope = (y2 - y1) / (x2 - x1) + inter = (x2 * y1 - x1 * y2) / (x2 - x1) + + # Which side should we delete the lines from? + temp = x0 * slope + inter + if (temp <= y0) + lessthan = NO + else + lessthan = YES + + # Search for points with X values between x1 and x2 + do i = 1 , npix { + if ((deleted[i] == YES && undelete == NO) || + (deleted[i] == NO && undelete == YES)) + next + + if (x[i] <= x2 && x[i] >= x1) { + # Now which side of the line does this point fall on + temp = x[i] * slope + inter + if (y[i] < temp && lessthan == YES) { + if (undelete == NO) { + deleted[i] = YES + # Plot X over point + call gseti (gd, G_PMLTYPE, GL_SOLID) + call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE) + } else { + deleted[i] = NO + call gseti (gd, G_PMLTYPE, GL_CLEAR) + call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE) + } + } else if (y[i] > temp && lessthan == NO) { + if (undelete == NO) { + deleted[i] = YES + # Plot X over point + call gseti (gd, G_PMLTYPE, GL_SOLID) + call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE) + } else { + deleted[i] = NO + call gseti (gd, G_PMLTYPE, GL_CLEAR) + call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE) + } + } + } + } +end + +# GT_PDEL -- Overplot crosses on those points which have been marked for zap. + +procedure gt_pdel (gd, x, y, deleted, npix) + +pointer gd +real x[ARB] +real y[ARB] +int deleted[ARB] +int npix + +int i + +begin + do i = 1, npix { + if (deleted[i] == YES) { + # Plot X over point + call gseti (gd, G_PMLTYPE, GL_SOLID) + call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE) + } + } +end diff --git a/pkg/utilities/nttools/gtedit/gtdodel.x b/pkg/utilities/nttools/gtedit/gtdodel.x new file mode 100644 index 00000000..7292048c --- /dev/null +++ b/pkg/utilities/nttools/gtedit/gtdodel.x @@ -0,0 +1,41 @@ +include + +# GT_DODEL -- Actually delete the rows marked for deletion + +procedure gt_dodel (tp, tpr, deleted, npix) + +pointer tp +pointer tpr +int deleted[ARB] # io: Array of deleted flags +int npix # io: # of rows in table + +int i, j, k + +int tbpsta() + +begin + if (tpr != NULL) { + # Append to whatever is already in the table + k = tbpsta (tpr, TBL_NROWS) + do i = 1, npix { + if (deleted[i] == YES) { + k = k + 1 + call tbrcpy (tp, tpr, i, k) + } + } + } + + for (j = npix; j> 0; j = j - 1) { + if (deleted[j] == YES) { + i = j + while (deleted[i] == YES) { + i = i - 1 + if (i < 1) + break + } + i = i + 1 + call tbrdel (tp, i, j) + j = i - 1 + } + } +end diff --git a/pkg/utilities/nttools/gtedit/gtedit.key b/pkg/utilities/nttools/gtedit/gtedit.key new file mode 100644 index 00000000..2a51e584 --- /dev/null +++ b/pkg/utilities/nttools/gtedit/gtedit.key @@ -0,0 +1,25 @@ + GTEDIT Interactive Cursor Commands + +? Print options +: Colon commands +a print out the complete row for the data point nearest the cursor +b delete all points with Y values less than the cursor Y position +c mark the corner of a box +d delete the point nearest the cursor +e exit and save changes in the output table +f make all the marked deletions and replot remaining data +h print out the column names of the input table +l delete all points with X values less than the cursor Y position +p replot the graph possibly using new data columns +q quit and do not save changes made since the last 'f' +r delete all points with X values greater than the cursor Y position +s mark one end of a line segment +t delete all points with Y values greater than the cursor Y position +u toggle between delete and undelete mode +v change from gtedit to tedit mode +z display current status (delete or undelete) + +:x(-) xcolumn set the table column for the X axis and possibly replot +:y(-) ycolumn set the table column for the Y axis and possibly replot + +- do not automatically replot after reading in new column diff --git a/pkg/utilities/nttools/gtedit/gthinfo.x b/pkg/utilities/nttools/gtedit/gthinfo.x new file mode 100644 index 00000000..dbc3d345 --- /dev/null +++ b/pkg/utilities/nttools/gtedit/gthinfo.x @@ -0,0 +1,69 @@ +include +include +include # FIO +include # TBtables + +# GT_HINFO -- Get the title and axes labels for the plot + +procedure gt_hinfo (tp, xlabel, ylabel, xcolumn, ycolumn, maxch) + +pointer tp # Table pointer +char xlabel[SZ_LINE] # Axis label strings (output) +char ylabel[SZ_LINE] # Axis label strings (output) +char xcolumn[SZ_COLNAME] # X column +char ycolumn[SZ_COLNAME] # Y column +int maxch + +char colunit[SZ_COLUNITS] +char errmsg[SZ_LINE] # Error message +pointer xcd, ycd + +int strlen() +bool streq() + +begin + # Single table; X and Y column + + if (!streq (xcolumn, NULL)) { + call tbcfnd (tp, xcolumn, xcd, 1) + if (xcd <= 0) { + call sprintf (errmsg, SZ_LINE, "Cannot find column %s") + call pargstr (xcolumn) + call error (0, errmsg) + } + # X axis label comes from column name + call sprintf (xlabel, maxch, "%s") + call pargstr (xcolumn) + } else { + call sprintf (xlabel, maxch, "%s") + call pargstr ("Number") + } + + # Find the column units + call tbcigt (xcd, TBL_COL_UNITS, colunit, SZ_COLUNITS) + if (colunit[1] != EOS) { + # Column units exist; append to X label + call sprintf (xlabel[strlen (xlabel)+1], maxch, " [%s]") + call pargstr (colunit) + } + + call tbcfnd (tp, ycolumn, ycd, 1) + if (ycd <= 0) { + call sprintf (errmsg, SZ_LINE, "Cannot find column %s") + call pargstr (ycolumn) + call error (0, errmsg) + } + + # Y label comes from column name + call sprintf (ylabel, maxch, "%s") + call pargstr (ycolumn) + + # Find the column units + call tbcigt (ycd, TBL_COL_UNITS, colunit, SZ_COLUNITS) + if (colunit[1] != EOS) { + # Column units exist; append to Y label + call sprintf (ylabel[strlen (ylabel)+1], maxch, " [%s]") + call pargstr (colunit) + } + +end diff --git a/pkg/utilities/nttools/gtedit/gtplot.x b/pkg/utilities/nttools/gtedit/gtplot.x new file mode 100644 index 00000000..160ed978 --- /dev/null +++ b/pkg/utilities/nttools/gtedit/gtplot.x @@ -0,0 +1,501 @@ +include +include +include +include +include +include # FIO +include # GIO +include # TBtables + +define HELPFILE "tables$pkg/ttools/gtedit/gtedit.key" # (BPS 05.31.94) +define GT_QUIT 0 +define GT_EXIT 1 + +procedure gteplot (device, input, tp, tpr, deleted, xcolumn, ycolumn, x, y, + size, null, npix, table_name, status) + +char device[SZ_FNAME] # Graphics device +char input[SZ_FNAME] # Input table name +pointer tp # Table descriptor +pointer tpr # Reject Table descriptor +pointer deleted # Pointer for array of delete flags +char xcolumn[SZ_COLNAME] # X column in table +char ycolumn[SZ_COLNAME] # Y column in table +pointer x +pointer y +pointer size # Size of markers to plot +pointer null # +int npix # Number of points per curve +char table_name[SZ_FNAME] # Table name +int status # return status + +pointer gd +int mode, npix_save +char col_save[SZ_COLNAME] +char xlabel[SZ_LINE], ylabel[SZ_LINE] +char plotitle[2*SZ_LINE] +char marker[SZ_FNAME] +char cmd[SZ_LINE] +char bad_column[SZ_COLNAME] +bool xautoscale, yautoscale, mark_del +bool drawbox, rdmarks +bool silent, readonly, inplace, auto_replot +int xtran, ytran, ticklabels, marker_type, j, drawgrid +int wcs, key, ip +int undelete +real px, py +real wx1, wx2, wy1, wy2, szmarker, vx1, vx2, vy1, vy2 +real wb, wt, wl, wr +real tol, xx, yy, sz +real x1, y1, x2, y2 +pointer sp, system_id, errmsg + +string bell "\007" +define replot_ 91 +define next_ 92 + +pointer gopen() +bool clgetb() +int strncmp() +int clgeti(), gstati() +int clgcur() +real clgetr() +pointer tbtopn() +errchk clgetb, clgeti, clgstr, clgetr, glabax, gpmark +errchk gswind, gseti, gascale, grscale + +begin + call smark (sp) + call salloc (system_id, SZ_LINE, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + mode = NEW_FILE + mark_del = false + undelete = NO + + # Get the marker character to be drawn at + # each point. The size of the character is given by szmarker. If + # zero and the input operadd is a list, marker sizes are taken + # individually from the third column of each list element. If + # negative, all markers are of size |szmarker| in NDC. If + # positive and the input operand is a list, the size of a marker + # is the third column of each list element times szmarker. + + szmarker = 0.0 + rdmarks = false + + # Draw markers only + call clgstr ("marker", marker, SZ_FNAME) + call init_mark2 (marker, marker_type) + if (marker_type != GM_POINT) { + szmarker = clgetr ("szmarker") + rdmarks = (szmarker <= 0) + } + + gd = gopen (device, mode, STDGRAPH) + + call gsetr (gd, G_PLWIDTH, 2.0) + + tol = 10.0 * EPSILONR + xautoscale = false + yautoscale = false + + # Set window and viewport. If user window has not been set, enable + # autoscaling. If device viewport has not been set, let glabax + # handle the viewport internally. + + call gclear (gd) + wx1 = clgetr ("wx1") + wx2 = clgetr ("wx2") + wy1 = clgetr ("wy1") + wy2 = clgetr ("wy2") + + if (abs (wx2 - wx1) < tol) + xautoscale = true + if (abs (wy2 - wy1) < tol) + yautoscale = true + + vx1 = clgetr ("vx1") + vx2 = clgetr ("vx2") + vy1 = clgetr ("vy1") + vy2 = clgetr ("vy2") + + if ((abs (vx2 - vx1) > tol) && (abs (vy2 - vy1) > tol)) + call gsview (gd, vx1, vx2, vy1, vy2) + + if (!clgetb ("fill")) + call gseti (gd, G_ASPECT, 1) + + if (clgetb ("round")) + call gseti (gd, G_ROUND, YES) + +replot_ + # Draw box around plot? + drawbox = false + if (mode != APPEND) + if (clgetb ("box")) + drawbox = true + + if (drawbox) { + # Get number of major and minor tick marks. + call gseti (gd, G_XNMAJOR, clgeti ("majrx")) + call gseti (gd, G_XNMINOR, clgeti ("minrx")) + call gseti (gd, G_YNMAJOR, clgeti ("majry")) + call gseti (gd, G_YNMINOR, clgeti ("minry")) + + # Fetch labels and plot title string. + + call clgstr ("xlabel", xlabel, SZ_LINE) + call clgstr ("ylabel", ylabel, SZ_LINE) + + call gt_hinfo (tp, xlabel, ylabel, xcolumn, ycolumn, SZ_LINE) + + # Label tick marks on axes? + ticklabels = NO + if (clgetb ("ticklabels")) + ticklabels = YES + + # Draw grid ? + drawgrid = NO + if (clgetb ("grid")) + drawgrid = YES + + call gseti (gd, G_DRAWGRID, drawgrid) + } + + # Log scale? Call gswind to set log scaling regardless of whether + # the user window is known; if the user window was not input, + # autoscaling will reset it later. + + if (mode == APPEND) { + xtran = gstati (gd, G_XTRAN) + ytran = gstati (gd, G_YTRAN) + call ggwind (gd, wx1, wx2, wy1, wy2) + } else { + xtran = GW_LINEAR + if (clgetb ("logx")) + xtran = GW_LOG + ytran = GW_LINEAR + if (clgetb ("logy")) + ytran = GW_LOG + call gswind (gd, wx1, wx2, wy1, wy2) + call gseti (gd, G_XTRAN, xtran) + call gseti (gd, G_YTRAN, ytran) + } + + # Autoscale if enabled. + if (xautoscale) { + call gascale (gd, Memr[x], npix, 1) + } + call ggwind (gd, wl, wr, wb, wt) + + if (yautoscale) { + # Overplot multiple curves on the same viewport + call gascale (gd, Memr[y], npix, 2) + } + + if (drawbox) { + # Draw box around plot + call gseti (gd, G_LABELTICKS, ticklabels) + # Overplot multiple curves on the same viewport + call strcpy ("", plotitle, SZ_FNAME) + call glabax (gd, plotitle, xlabel, ylabel) + } + + # Markers at each point with no connection + if (rdmarks) { + # Variable marker sizes + if (szmarker < 0) + # World coordinate marker sizes + call amulkr (Memr[size], -szmarker, Memr[size], + npix) + do j = 1, npix { # For each point in the curve + xx = Memr[x+j-1] + yy = Memr[y+j-1] + sz = Memr[size+j-1] + call gmark (gd, xx, yy, marker_type, sz, sz) + } + } else { + call gpmark (gd, Memr[x], Memr[y],npix, marker_type, + szmarker, szmarker) + } + + # We have plotted things so now is the time to let the user + # do his thing. + + # Over plot crosses for those points which have been deleted + if (mark_del) { + call gt_pdel (gd, Memr[x], Memr[y], Memr[deleted], npix) + mark_del = false + } + +next_ + while (clgcur ("commands", px, py, wcs, key, cmd, SZ_LINE) + != EOF) { + + switch (key) { + + # Quit and do not make changes + case 'q': + status = GT_QUIT + break + + # Exit and do the changes + case 'e': + status = GT_EXIT + break + + # Help page + case '?': + if (gd == NULL) + call pagefile (HELPFILE, "") + else + call gpagefile (gd, HELPFILE, "") + + # Simply replot (may have new columns) + case 'p': + call gclear (gd) + mark_del = true + goto replot_ + + # Mark the corners of a box and delete the points within + case 'c': + x1 = px; y1 = py + call gmark (gd, x1, y1, GM_DIAMOND, 1., 1.) + call printf ("again:") + if (clgcur ("commands", px, py, wcs, key, cmd, SZ_LINE) == EOF) + goto next_ + + call gt_dbox (gd, npix, Memi[deleted], undelete, Memr[x], + Memr[y], x1, y1, px, py) + + # Mark the end points of a line segment and delete points on + # one side of this segment (indicated by user) for points with + # X values between x1 and x2 + case 's': + x1 = px; y1 = py + call gmark (gd, x1, y1, GM_DIAMOND, 1., 1.) + call printf ("again:") + if (clgcur ("commands", px, py, wcs, key, cmd, SZ_LINE) == EOF) + goto next_ + x2 = px + y2 = py + call gmark (gd, x1, y1, GM_DIAMOND, 1., 1.) + call gline (gd, x1, y1, x2, y2) + call printf ("Move cursor to one side of line and hit any key") + if (clgcur ("commands", px, py, wcs, key, cmd, SZ_LINE) == EOF) + goto next_ + + call gt_dseg (gd, npix, Memi[deleted], undelete, Memr[x], + Memr[y], x1, y1, x2, y2, px, py) + + # Update graph (delete points and replot) + case 'f': + call gt_update (tp, tpr, Memr[x], Memr[y], Memi[deleted], npix) + call gclear (gd) + goto replot_ + + # Print out the complete record for this point + case 'a': + call gt_wrdata (gd, tp, px, py, Memr[x], Memr[y], npix) + + # Print out the column names + case 'h': + call gt_wrhead (gd, tp) + + # Delete a point + case 'd': + call gt_delpt (gd,px, py, Memr[x], Memr[y], npix, + Memi[deleted], undelete) + + # Undelete a point + case 'u': + if (undelete == YES) { + undelete = NO + call printf ("Now deleting points\n") + } else { + undelete = YES + call printf ("Now undeleting points\n") + } + + # Revert to normal table editor + case 'v': + silent = false + readonly = false + inplace = false + + # First update the table + call gt_update (tp, tpr, Memr[x], Memr[y], Memi[deleted], npix) + call tbtclo (tp) + call gdeactivate (gd, 0) + call edit (table_name, " ", silent, readonly, inplace) + + # Now read in the data (which may have been edited + npix_save = npix + tp = tbtopn (table_name, READ_WRITE, NULL) + call gt_rdxycol (tp, xcolumn, ycolumn, x, y, size, null, npix, + bad_column) + if (npix < 0) { + npix = npix_save + call printf ("Cannot find column %s") + call pargstr (bad_column) + } + call greactivate (gd, AW_PAUSE) + call gclear (gd) + goto replot_ + + # Undelete status + case 'z': + if (undelete == NO) { + call printf ("Currently deleting points\n") + } else { + call printf ("Currently undeleting points\n") + } + + # Delete points > Y + case 't': + call gt_dygt (gd, py, Memr[x], Memr[y], npix, + Memi[deleted], undelete) + + # Delete points < Y + case 'b': + call gt_dylt (gd, py, Memr[x], Memr[y], npix, + Memi[deleted], undelete) + + # Delete points > X + case 'r': + call gt_dxgt (gd, px, Memr[x], Memr[y], npix, + Memi[deleted], undelete) + + # Delete points < X + case 'l': + call gt_dxlt (gd, px, Memr[x], Memr[y], npix, + Memi[deleted], undelete) + + # Colon commands: + case ':': + # Command mode + for (ip=1; IS_WHITE (cmd[ip]); ip = ip + 1) + ; + + switch (cmd[ip]) { + case 'x': + # Read in a new X column + ip = ip + 1 + auto_replot = true + if (strncmp (cmd[ip], "-", 1) == 0) { + ip = ip + 1 + auto_replot = false + } + call amovc (xcolumn, col_save, SZ_COLNAME) + call ctowrd (cmd, ip, xcolumn, SZ_FNAME) + npix_save = npix + call gt_rdxycol (tp, xcolumn, ycolumn, x, y, size, null, + npix, bad_column) + if (npix < 0) { + npix = npix_save + call gdeactivate (gd, 0) + call printf ("Cannot find column %s") + call pargstr (bad_column) + call greactivate (gd, 0) + call amovc (col_save, xcolumn, SZ_COLNAME) + } + if (auto_replot) { + call gclear (gd) + mark_del = true + goto replot_ + } + + case 'y': + # Read in a new Y column + ip = ip + 1 + auto_replot = true + if (strncmp (cmd[ip], "-", 1) == 0) { + ip = ip + 1 + auto_replot = false + } + call amovc (ycolumn, col_save, SZ_COLNAME) + call ctowrd (cmd, ip, ycolumn, SZ_FNAME) + npix_save = npix + call gt_rdxycol (tp, xcolumn, ycolumn, x, y, + size, null, npix, bad_column) + if (npix < 0) { + call gdeactivate (gd, 0) + npix = npix_save + call printf ("Cannot find column %s") + call pargstr (bad_column) + call greactivate (gd, 0) + call amovc (col_save, ycolumn, SZ_COLNAME) + } + if (auto_replot) { + call gclear (gd) + mark_del = true + goto replot_ + } + + default: + call printf (bell) + + } + + default: + call printf (bell) + + } + } + call sfree (sp) + call gclose (gd) +end + +# TGR_ONINT2 -- Interrupt handler for the task graph. Branches back to ZSVJMP +# in the main routine to permit shutdown without an error message. + +procedure tgr_onint2 (vex, next_handler) + +int vex # Virtual exception +int next_handler # not used + +int tgrjmp[LEN_JUMPBUF] +common /tgrcom/ tgrjmp + +begin + call xer_reset() + call zdojmp (tgrjmp, vex) +end + + +# INIT_MARK2 -- Returns integers code for marker type string. + +procedure init_mark2 (marker, imark) + +char marker[SZ_FNAME] # Marker type as a string +int imark # Integer code for marker - returned + +bool streq() + +begin + if (streq (marker, "point")) + imark = GM_POINT + else if (streq (marker, "box")) + imark = GM_BOX + else if (streq (marker, "plus")) + imark = GM_PLUS + else if (streq (marker, "cross")) + imark = GM_CROSS + else if (streq (marker, "circle")) + imark = GM_CIRCLE + else if (streq (marker, "hebar")) + imark = GM_HEBAR + else if (streq (marker, "vebar")) + imark = GM_VEBAR + else if (streq (marker, "hline")) + imark = GM_HLINE + else if (streq (marker, "vline")) + imark = GM_VLINE + else if (streq (marker, "diamond")) + imark = GM_DIAMOND + else { + call eprintf ("Unrecognized marker type, using 'box'\n") + imark = GM_BOX + } +end diff --git a/pkg/utilities/nttools/gtedit/gtrdxycol.x b/pkg/utilities/nttools/gtedit/gtrdxycol.x new file mode 100644 index 00000000..8bf47f98 --- /dev/null +++ b/pkg/utilities/nttools/gtedit/gtrdxycol.x @@ -0,0 +1,50 @@ +include +include + +# GT_RDXYCOL -- read X and Y plot data from two column of the same table + +procedure gt_rdxycol (tp, xcolumn, ycolumn, x, y, size, null, numrows, bad_column) + +pointer tp # Table descriptor +char xcolumn[SZ_COLNAME], ycolumn[SZ_COLNAME] # Column names +pointer x, y, size # Pointers to x, y and size vectors +int numrows # number of pixels or rows in the table +char bad_column[SZ_COLNAME] # Return bad column name + +pointer xcdp, ycdp # Pointers to column descriptors +pointer null # Pointer to null +int numcols +int i + +int tbpsta() +bool streq() + +begin + numcols = 1 + numrows = tbpsta (tp, TBL_NROWS) + call aclrc (bad_column, SZ_COLNAME) + + if (streq (xcolumn, NULL)) { + do i = 1, numrows + Memr[x + i - 1] = float(i) + } else { + call tbcfnd (tp, xcolumn, xcdp, numcols) + if (xcdp <= 0) { + numrows = -1 + call amovc (xcolumn, bad_column, SZ_COLNAME) + return + } + call tbcgtr (tp, xcdp, Memr[x], Memb[null], 1, numrows) + } + + call tbcfnd (tp, ycolumn, ycdp, numcols) + if (ycdp <= 0) { + numrows = -1 + call amovc (ycolumn, bad_column, SZ_COLNAME) + return + } + + call tbcgtr (tp, ycdp, Memr[y], Memb[null], 1, numrows) + + return +end diff --git a/pkg/utilities/nttools/gtedit/gtupdate.x b/pkg/utilities/nttools/gtedit/gtupdate.x new file mode 100644 index 00000000..7308c38f --- /dev/null +++ b/pkg/utilities/nttools/gtedit/gtupdate.x @@ -0,0 +1,36 @@ +# GT_UPDATE -- Delete points currently marked for deletion and update data + +procedure gt_update (tp, tpr, x, y, deleted, npix) + +pointer tp, tpr +real x[ARB] +real y[ARB] +int npix +int deleted[ARB] + +int i, j, ndelete + +begin + # Delete the points + call gt_dodel (tp, tpr, deleted, npix) + + # Update data arrays j = 0 + ndelete = 0 + for (i = 1; i <= npix; i = i + 1) { + j = j + 1 + if (deleted[i] == YES) { + ndelete = ndelete + 1 + i = i + 1 + while (deleted[i] == YES) { + ndelete = ndelete + 1 + i = i + 1 + } + } + x[j] = x[i] + y[j] = y[i] + } + + call aclri (deleted, npix) + npix = npix - ndelete +end + diff --git a/pkg/utilities/nttools/gtedit/gtwrdata.x b/pkg/utilities/nttools/gtedit/gtwrdata.x new file mode 100644 index 00000000..bc0022e2 --- /dev/null +++ b/pkg/utilities/nttools/gtedit/gtwrdata.x @@ -0,0 +1,90 @@ +include +include +include + +# GT_WRDATA -- Write out the complete table record for this point + +procedure gt_wrdata (gd, tp, wx, wy, x, y, npix) + +pointer gd # Graphics descriptor +pointer tp # Table descriptor +real wx # Cursor position +real wy # "" +real x[ARB] # Plotted data +real y[ARB] # Plotted data +int npix # # of pixels + +pointer sp +pointer cname, cunits, cfmt # pointers to scratch space for column info +pointer ctext, cp +int row, i, colnum, datatype, lendata, lenfmt, ncols +int ip +real r2min, r2, x0, y0 + +pointer tbpsta(), tbcnum() + +begin + # Allocate some space + call smark (sp) + call salloc (cname, SZ_LINE, TY_CHAR) + call salloc (cunits, SZ_LINE, TY_CHAR) + call salloc (cfmt, SZ_COLFMT, TY_CHAR) + call salloc (ctext, SZ_LINE, TY_CHAR) + + # Search for the nearest point + row = 0 + r2min = MAX_REAL + + # Transform world cursor coordintes to NDC + call gctran (gd, wx, wy, wx, wy, 1, 0) + do i = 1 , npix { + call gctran (gd, x[i], y[i], x0, y0, 1, 0) + if (x[i] < INDEFR && y[i] < INDEFR) + r2 = (wx - x0) ** 2 + (wy - y0) ** 2 + else + r2 = MAX_REAL + + if (r2 < r2min) { + r2min = r2 + row = i + } + } + + if (row != 0) { + # Deactivate the workstation + call gdeactivate (gd, 0) + # Now get the info on the columns + ncols = tbpsta (tp, TBL_NCOLS) + + call printf ("\n") + do i = 1, ncols { + cp = tbcnum (tp, i) + call tbcinf (cp, + colnum, Memc[cname], Memc[cunits], Memc[cfmt], + datatype, lendata, lenfmt) + + # Print column units (ignore trailing blanks) + # (calling sequence of inquotes modified by PEH on 13 Jan 1995) + call inquotes (Memc[cunits], Memc[cunits], SZ_LINE, NO) + call printf (" %-14s ") + call pargstr (Memc[cunits]) + + # Print column name (and include trailing blanks) + call inquotes (Memc[cname], Memc[cname], SZ_LINE, YES) + call printf ("%-16s ") + call pargstr (Memc[cname]) + + #Print column value + # Modified by by PEH, 9 Sept 1994: + # remove case statement, and skip leading blanks. + call tbegtt (tp, cp, row, Memc[ctext], SZ_LINE) + ip = 0 + while (Memc[ctext+ip] == ' ') + ip = ip + 1 + call printf ("%s\n") + call pargstr (Memc[ctext+ip]) + } + } + call greactivate (gd, AW_PAUSE) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/gtedit/gtwrhead.x b/pkg/utilities/nttools/gtedit/gtwrhead.x new file mode 100644 index 00000000..2b941be4 --- /dev/null +++ b/pkg/utilities/nttools/gtedit/gtwrhead.x @@ -0,0 +1,47 @@ +include +include + +# GT_WRHEAD -- Write out the column names of the table + +procedure gt_wrhead (gd, tp) + +pointer gd # Graphics descriptor +pointer tp # Table descriptor + +pointer sp +pointer cname, cunits, cfmt # pointers to scratch space for column info +pointer ctext, cp +int i, colnum, datatype, lendata, lenfmt, ncols + +pointer tbpsta(), tbcnum() + +begin + # Allocate some space + call smark (sp) + call salloc (cname, SZ_LINE, TY_CHAR) + call salloc (cunits, SZ_LINE, TY_CHAR) + call salloc (cfmt, SZ_COLFMT, TY_CHAR) + call salloc (ctext, SZ_LINE, TY_CHAR) + + # Deactivate the workstation + call gdeactivate (gd, 0) + # Now get the info on the columns + ncols = tbpsta (tp, TBL_NCOLS) + + call printf ("Column names:\n\n") + do i = 1, ncols { + cp = tbcnum (tp, i) + call tbcinf (cp, + colnum, Memc[cname], Memc[cunits], Memc[cfmt], + datatype, lendata, lenfmt) + + # Print column name (and include trailing blanks) + # (calling sequence of inquotes modified by PEH on 13 Jan 1995) + call inquotes (Memc[cname], Memc[cname], SZ_LINE, YES) + call printf ("%-16s \n") + call pargstr (Memc[cname]) + + } + call greactivate (gd, AW_PAUSE) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/gtedit/mkpkg b/pkg/utilities/nttools/gtedit/mkpkg new file mode 100644 index 00000000..6c58f092 --- /dev/null +++ b/pkg/utilities/nttools/gtedit/mkpkg @@ -0,0 +1,19 @@ +# GTEDIT task +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + gtdelete.x + gtdodel.x + gthinfo.x + gtplot.x \ + + gtrdxycol.x + gtupdate.x + gtwrdata.x + gtwrhead.x + t_gtedit.x \ + + ; diff --git a/pkg/utilities/nttools/gtedit/t_gtedit.x b/pkg/utilities/nttools/gtedit/t_gtedit.x new file mode 100644 index 00000000..dc1b105d --- /dev/null +++ b/pkg/utilities/nttools/gtedit/t_gtedit.x @@ -0,0 +1,184 @@ +include +include +include +include +include +include +include +include +include # TBtables + +define GT_QUIT 0 +define GT_EXIT 1 + +# GTEDIT -- Interactive STSDAS Table editor. + +procedure t_gtedit() + +pointer input # Name of input table +pointer device +pointer xcolumn # Name of column for X +pointer ycolumn # Name of column for Y +pointer output +pointer reject +pointer scrname +bool inplace + +pointer x, y, null, size, sp, tp, deleted, tpr +pointer errmsg, bad_column +int npix +int window # note: this is apparently not used +int phu_copied # set by tbfpri and ignored +int tgrjmp[LEN_JUMPBUF], epa, old_onint, status +bool do_delete, do_quit + +bool clgetb() +int fstati(), scan(), strncmp(), tbpsta() +pointer tbtopn() +extern tgr_onint2() +data window /0/ +common /tgrcom/ tgrjmp + +begin + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Initialize curve pointers to NULL, in case ggplot aborts without + # allocating any buffers. + x = NULL + y = NULL + size = NULL + npix = NULL + + # Get some Memory + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (device, SZ_FNAME, TY_CHAR) + call salloc (xcolumn, SZ_FNAME, TY_CHAR) + call salloc (ycolumn, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (reject, SZ_FNAME, TY_CHAR) + call salloc (scrname, SZ_FNAME, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + call salloc (bad_column, SZ_COLNAME, TY_CHAR) + call aclrc (Memc[reject], SZ_FNAME) + call aclrc (Memc[output], SZ_FNAME) + + call clgstr ("input", Memc[input], SZ_FNAME) + + # Fetch plotting parameters. + call clgstr ("device", Memc[device], SZ_FNAME) + + # Get column names etc. + call clgstr ("xcolumn", Memc[xcolumn], SZ_FNAME) + call clgstr ("ycolumn", Memc[ycolumn], SZ_FNAME) + inplace = clgetb ("inplace") # modified by PEH 13-Jul-92 + + # Do we need to get the output file name + if (!inplace) { + call clgstr ("output", Memc[output], SZ_FNAME) + if (strncmp (Memc[output], "", 1) == 0) { + call clpstr ("gtedit.output.p_mode", "q") + call clgstr ("output", Memc[output], SZ_FNAME) + call clpstr ("gtedit.output.p_mode", "h") + } + } + call clgstr ("reject", Memc[reject], SZ_FNAME) + + if (inplace) { + # Copy the name of the table to scrname and open it by that name + call strcpy (Memc[input], Memc[scrname], SZ_FNAME) + tp = tbtopn (Memc[scrname], READ_WRITE, 0) + } else { + # Copy the table to the output and work on the output. + # The call to fcopy was replaced by tbtcpy by PEH on 8-Nov-1993. + # The call to tbfpri was added by PEH on 8-Apr-1999. + call tbfpri (Memc[input], Memc[output], phu_copied) + call tbtcpy (Memc[input], Memc[output]) + tp = tbtopn (Memc[output], READ_WRITE, 0) + } + + # Number of rows + npix = tbpsta (tp, TBL_NROWS) + iferr { + call malloc (x, npix, TY_REAL) + call malloc (y, npix, TY_REAL) + call malloc (size, npix, TY_REAL) + call malloc (null, npix, TY_REAL) + } then + call erract (EA_FATAL) + + + # Open reject table if required + tpr = NULL + if (Memc[reject] != EOS) { + tpr = tbtopn (Memc[reject], NEW_COPY, tp) + call tbtcre (tpr) + call tbhcal (tp, tpr) + } + + # Install interrupt exception handler. + call zlocpr (tgr_onint2, epa) + call xwhen (X_INT, epa, old_onint) + + call zsvjmp (tgrjmp, status) + if (status == OK) { + # Fetch remaining params and draw the plot. + call gt_rdxycol (tp, Memc[xcolumn], Memc[ycolumn], x, y, size, + null, npix, Memc[bad_column]) + + # Exit if no column + if (npix < 0) { + call sprintf (Memc[errmsg], SZ_LINE, "Cannot find column %s") + call pargstr (Memc[bad_column]) + call error (0, Memc[errmsg]) + } + # Now allocate space for the deleted array + call salloc (deleted, npix, TY_INT) + call aclri (Memi[deleted], npix) + + call gteplot (Memc[device], Memc[input], tp, tpr, deleted, + Memc[xcolumn], Memc[ycolumn], x, y, size, null, npix, + Memc[input], status) + } + + if (status == GT_EXIT) { + + # Actually delete the rows and save rejects (if requested) + call printf ("Please confirm update of output table [y/n]: ") + call flush (STDOUT) + if (scan() == EOF) + call gt_dodel (tp, tpr, Memi[deleted], npix) + else { + call gargb (do_delete) + if (do_delete) + call gt_dodel (tp, tpr, Memi[deleted], npix) + } + } else if (status == GT_QUIT) { + + call printf ( + "Please confirm quit with NO update of output table [y/n]: ") + call flush (STDOUT) + do_quit = false # bug fix from Doug Tody, 22-Jan-1993 + if (scan() != EOF) + call gargb (do_quit) + if (!do_quit) + call gt_dodel (tp, tpr, Memi[deleted], npix) + } else if (status == ERR) + call fseti (STDOUT, F_CANCEL, OK) + + # Close table + call tbtclo (tp) + if (tpr != NULL) + call tbtclo (tpr) + + # Return buffer space whether or not an error occurs while plotting. + + call mfree (x, TY_REAL) + call mfree (y, TY_REAL) + call mfree (size, TY_REAL) + call mfree (null, TY_REAL) + + call sfree (sp) + +end diff --git a/pkg/utilities/nttools/gtpar.par b/pkg/utilities/nttools/gtpar.par new file mode 100644 index 00000000..c5e66541 --- /dev/null +++ b/pkg/utilities/nttools/gtpar.par @@ -0,0 +1,27 @@ +wx1,r,h,0.,,,left world x-coord if not autoscaling +wx2,r,h,0.,,,right world x-coord if not autoscaling +wy1,r,h,0.,,,lower world y-coord if not autoscaling +wy2,r,h,0.,,,upper world y-coord if not autoscaling +marker,s,h,"box","point|box|plus|cross|circle|diamond|hline|vline|hebar|vebar",\ +,"point marker character: \n\ + point, box, plus, cross, circle,\n\ + diamond, hline, vline, hebar, vebar" +szmarker,r,h,5E-3,,,marker size (0 => list input; < 0 => NDC) +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? +grid,b,h,no,,,draw grid lines on plot +xlabel,s,h,"",,,x-axis label +ylabel,s,h,"",,,y-axis label +title,s,h,"imtitle",,,title for plot +vx1,r,h,0.,,,left limit of device viewport (0.0:1.0) +vx2,r,h,0.,,,right limit of device viewport (0.0:1.0) +vy1,r,h,0.,,,bottom limit of device viewport (0.0:1.0) +vy2,r,h,0.,,,upper limit of device viewport (0.0:1.0) +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,yes,,,fill viewport vs enforce unity aspect ratio? diff --git a/pkg/utilities/nttools/imtab.par b/pkg/utilities/nttools/imtab.par new file mode 100644 index 00000000..8cbdb470 --- /dev/null +++ b/pkg/utilities/nttools/imtab.par @@ -0,0 +1,8 @@ +input,s,a,"",,,"name of input image" +outtable,s,a,"",,,"name of output table" +colname,s,a,"",,,"name of column for image data" +pname,s,h,"",,,"root for pixel position column name, or null" +wcs,s,h,"logical","logical|physical|world",,"coordinate system for pixels" +formats,s,h,"",,,"list of pixel coordinate formats" +tbltype,s,h,"default","default|row|column|text",,"row or column ordered table" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/imtab/imtab.h b/pkg/utilities/nttools/imtab/imtab.h new file mode 100644 index 00000000..2f280d60 --- /dev/null +++ b/pkg/utilities/nttools/imtab/imtab.h @@ -0,0 +1,4 @@ +define IMTAB_NO_WCS 0 # pixel coordinates will not be written out +define IMTAB_LOGICAL 1 # wcs = logical +define IMTAB_PHYSICAL 2 # wcs = physical +define IMTAB_WORLD 3 # wcs = world diff --git a/pkg/utilities/nttools/imtab/imtab.x b/pkg/utilities/nttools/imtab/imtab.x new file mode 100644 index 00000000..8e8cb324 --- /dev/null +++ b/pkg/utilities/nttools/imtab/imtab.x @@ -0,0 +1,476 @@ +include +include # to check whether output is redirected +include +include # for MAX_SHORT +include +include "imtab.h" + +define NCOLS (1 + IM_MAXDIM) # max number of columns to write to the table + +# imtab -- create a table from an image +# This task copies data from an image to a table. Pixel values are +# read from the image line by line and written to a column in increasing +# row number. +# If the table already exists then columns will be added to it; note that +# the column names must not conflict with existing names. +# +# Phil Hodge, 10-Jan-1991 Task created. +# Phil Hodge, 17-Mar-1992 Include text as a valid table type; call pargstr +# to pass cname in case column name already exists. +# Phil Hodge, 16-Apr-1993 Include short datatype. +# Phil Hodge, 28-Sep-1993 Include wcs option for pixel coordinates. +# Phil Hodge, 13-Dec-1993 Slight changes to itb_init because of optimizer +# problems with SGI Fortran. +# Phil Hodge, 8-Jun-1999 Set output to STDOUT if redirected. +# Phil Hodge, 30-Mar-2000 Allow lists of names for input and output. + +procedure imtab() + +pointer input # name of an input image +pointer outlist # names of output tables +pointer outtable # name of an output table +char cname[SZ_COLNAME,NCOLS] # column names +char c_root[SZ_COLNAME] # root for column names for position +pointer wcs # wcs name if c_root != "" +pointer formats # list of formats for pixel coords +pointer ttype # type of output table (if new) +#-- +pointer sp +pointer im # pointer to image descriptors +pointer xps, xpr, xpd # pointer to input data from image +pointer tp # pointer to descriptor for output table +pointer cp[NCOLS] # column descriptors +pointer mw, ct # mwcs pointers + +pointer imt, tnt # pointers for filename templates +int nin, nout # numbers of names in lists +int junk + +long v[IM_MAXDIM] # for call to imgnld +int lcoords[IM_MAXDIM] # "logical" coordinates, copied from v +real ipcoords[IM_MAXDIM] # "logical" coordinates, copied from v +real opcoords[IM_MAXDIM] # "physical" coordinates from ipcoords +double iwcoords[IM_MAXDIM] # "logical" coordinates, copied from v +double owcoords[IM_MAXDIM] # "world" coordinates from iwcoords + +int wcs_type # wcs name as an int +int ax[IM_MAXDIM] # ax[i] is physical axis for logical axis i +real inr[IM_MAXDIM] # copy of input coordinates used by itb_ctranr +double ind[IM_MAXDIM] # copy of input coordinates used by itb_ctrand +int wcsdim # dimension of physical image coord system +int impixtype # data type of image + +int ncols # number of columns to create +int dtype[NCOLS] # data type of each table column +int frow, lrow # row number limits for tbcptd +int row # loop index +int i, j, k # loop indexes +bool done # loop-termination flag +int clgwrd() +int fstati() +int imgnls(), imgnlr(), imgnld() +pointer imtopenp(), tbnopen() +int imtlen(), imtgetim(), tbnlen(), tbnget() +bool streq() + +begin + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (outlist, SZ_LINE, TY_CHAR) + call salloc (outtable, SZ_FNAME, TY_CHAR) + call salloc (wcs, SZ_FNAME, TY_CHAR) + call salloc (formats, SZ_FNAME, TY_CHAR) + call salloc (ttype, SZ_FNAME, TY_CHAR) + + imt = imtopenp ("input") + nin = imtlen (imt) + + if (fstati (STDOUT, F_REDIR) == YES) + call strcpy ("STDOUT", Memc[outlist], SZ_LINE) + else + call clgstr ("outtable", Memc[outlist], SZ_LINE) + tnt = tbnopen (Memc[outlist]) + nout = tbnlen (tnt) + + # Compare the numbers of input and output names. + call itb_names (nin, nout, Memc[outlist]) + + # Get the column names. + call clgstr ("colname", cname[1,1], SZ_COLNAME) # name for data + call clgstr ("pname", c_root, SZ_COLNAME) # root name for position + call xt_stripwhite (c_root) + if (c_root[1] != EOS) { + wcs_type = clgwrd ("wcs", Memc[wcs], SZ_FNAME, + "|logical|physical|world") + call clgstr ("formats", Memc[formats], SZ_FNAME) + } else { + wcs_type = IMTAB_NO_WCS + Memc[formats] = EOS + } + + # What table type should be created? + if (streq (Memc[outlist], "STDOUT")) + call strcpy ("default", Memc[ttype], SZ_FNAME) + else + call clgstr ("tbltype", Memc[ttype], SZ_FNAME) + + # Loop over the list of input images. + while (imtgetim (imt, Memc[input], SZ_FNAME) != EOF) { + + if (nout == 1) + call tbnrew (tnt) + junk = tbnget (tnt, Memc[outtable], SZ_FNAME) + + # Open the input image and the wcs and get the column data types. + call itb_init (Memc[input], wcs_type, im, dtype) + impixtype = IM_PIXTYPE(im) + + # Initialize the wcs. + call itb_wcs_init (im, wcs_type, mw, ct, ax, wcsdim) + call amovkr (1., inr, IM_MAXDIM) + call amovkd (1.d0, ind, IM_MAXDIM) + + # Initialize for reading the image. + do k = 1, IM_MAXDIM + v[k] = 1 + + # Initialize for writing to the table. + row = 1 + frow = 1 + lrow = IM_LEN(im,1) + if (wcs_type == IMTAB_NO_WCS) + ncols = 1 + else if (wcs_type == IMTAB_LOGICAL) + ncols = 1 + IM_NDIM(im) + else if (wcs_type == IMTAB_PHYSICAL || wcs_type == IMTAB_WORLD) + ncols = 1 + wcsdim + + # Open or create the output table. + call itb_table (im, Memc[outtable], wcs_type, Memc[ttype], ncols, + cname, c_root, Memc[formats], dtype, tp, cp) + + # Copy each line of the image into a column of the table. + done = false + while (!done) { + + # Assign pixel index for all but the first axis. + if (wcs_type == IMTAB_LOGICAL) + do j = 2, ncols-1 + lcoords[j] = v[j] + else if (wcs_type == IMTAB_PHYSICAL) + do j = 2, ncols-1 + ipcoords[j] = real (v[j]) + else if (wcs_type == IMTAB_WORLD) + do j = 2, ncols-1 + iwcoords[j] = double (v[j]) + + if (impixtype == TY_SHORT || impixtype == TY_UBYTE) + done = (imgnls (im, xps, v) == EOF) + else if (impixtype == TY_REAL || impixtype == TY_USHORT) + done = (imgnlr (im, xpr, v) == EOF) + else + done = (imgnld (im, xpd, v) == EOF) + + if (!done) { + + # Write the pixel coordinates. + if (wcs_type == IMTAB_LOGICAL) { + do i = 1, IM_LEN(im,1) { # simply write pixel numbers + lcoords[1] = i + call tbrpti (tp, cp[2], lcoords, ncols-1, row) + row = row + 1 + } + } else if (wcs_type == IMTAB_PHYSICAL) { + do i = 1, IM_LEN(im,1) { + ipcoords[1] = real (i) + call itb_ctranr (im, ct, ax, inr, + ipcoords, opcoords, wcsdim) + call tbrptr (tp, cp[2], opcoords, ncols-1, row) + row = row + 1 + } + } else if (wcs_type == IMTAB_WORLD) { + do i = 1, IM_LEN(im,1) { + iwcoords[1] = double (i) + call itb_ctrand (im, ct, ax, ind, + iwcoords, owcoords, wcsdim) + call tbrptd (tp, cp[2], owcoords, ncols-1, row) + row = row + 1 + } + } + + # Copy image line into a portion of a column of the table. + if (impixtype == TY_SHORT || impixtype == TY_UBYTE) + call tbcpts (tp, cp[1], Mems[xps], frow, lrow) + else if (impixtype == TY_REAL || impixtype == TY_USHORT) + call tbcptr (tp, cp[1], Memr[xpr], frow, lrow) + else + call tbcptd (tp, cp[1], Memd[xpd], frow, lrow) + frow = frow + IM_LEN(im,1) + lrow = lrow + IM_LEN(im,1) + } + } + if (mw != NULL) + call mw_close (mw) # close mwcs + call imunmap (im) # close image + call tbtclo (tp) # close table + } + + call imtclose (imt) + call tbnclose (tnt) + + call sfree (sp) +end + +# This routine checks the number of input and output file names. +# The number of names in the input and output lists must be the same, +# unless all the input will be written to the standard output. + +procedure itb_names (nin, nout, outlist) + +int nin # i: number of input image names +int nout # i: number of output table names +char outlist[ARB] # i: output names (to be compared with "STDOUT") +#-- +bool strne() + +begin + if (nin == 0) + call error (1, "no input image specified") + + if (nout == 0) + call error (1, "no output table specified") + + if (nin != nout && strne (outlist, "STDOUT")) { + + if (nin == 1) { + call eprintf ("There is one input image") + } else { + call eprintf ("There are %d input images") + call pargi (nin) + } + if (nout == 1) { + call eprintf (" and one output table;\n") + } else { + call eprintf (" and %d output tables;\n") + call pargi (nout) + } + call error (1, "the lists must have the same length") + } +end + +# itb_init -- get data types and column info +# This routine opens the input image and gets the data type for each column. + +procedure itb_init (input, wcs_type, im, dtype) + +char input[ARB] # i: name of image +int wcs_type # i: type of wcs for pixel coordinates +pointer im # o: imhdr pointer +int dtype[NCOLS] # o: data type of each table column +#-- +int i # loop index +int fill_extra # dummy +pointer immap() + +begin + # Open input image. + im = immap (input, READ_ONLY, NULL) + + # Fewer data types are allowed for tables than for images. + switch (IM_PIXTYPE(im)) { + case TY_UBYTE, TY_SHORT: + dtype[1] = TY_SHORT + case TY_USHORT, TY_INT, TY_LONG: + dtype[1] = TY_INT + case TY_REAL: + dtype[1] = TY_REAL + case TY_DOUBLE: + dtype[1] = TY_DOUBLE + default: + call error (1, "image data type not supported for tables") + } + + # Set the data types of columns for pixel coordinates. + fill_extra = IM_NDIM(im) + 2 + if (wcs_type == IMTAB_NO_WCS) { + do i = 2, NCOLS + dtype[i] = TY_SHORT # ignored + + } else if (wcs_type == IMTAB_LOGICAL) { + # Check the image size to see if we can use TY_SHORT. + do i = 1, IM_NDIM(im) { + if (IM_LEN(im,i) > MAX_SHORT) + dtype[i+1] = TY_INT + else + dtype[i+1] = TY_SHORT + } + do i = fill_extra, NCOLS + dtype[i] = TY_SHORT # ignored + + } else if (wcs_type == IMTAB_PHYSICAL) { + do i = 2, NCOLS + dtype[i] = TY_REAL + + } else if (wcs_type == IMTAB_WORLD) { + do i = 2, NCOLS + dtype[i] = TY_DOUBLE + } +end + +# itb_table -- initialization for output table +# This routine opens the output table (or creates it if it doesn't already +# exist) and creates the columns for the data and the pixel coordinates. + +procedure itb_table (im, outtable, wcs_type, ttype, ncols, + cname, c_root, formats, dtype, tp, cp) + +pointer im # i: imhdr pointer for input image +char outtable[ARB] # i: name of output table +int wcs_type # i: type of wcs for pixel coordinates +char ttype[ARB] # i: table type (e.g. "row") +int ncols # i: total number of columns to write +char cname[SZ_COLNAME,NCOLS] # io: column names +char c_root[ARB] # i: root for column name for pixels +char formats[ARB] # i: user-specified formats for pixels +int dtype[NCOLS] # i: data types of table columns +pointer tp # o: pointer to table descriptor +pointer cp[NCOLS] # o: column descriptors +#-- +char colunits[SZ_COLUNITS,NCOLS] # column units +char colfmt[SZ_COLFMT,NCOLS] # column format +char history[SZ_FNAME] # for history records +int lendat[NCOLS] # one +int nrows +int i +bool new_table # true if the table does not already exist +bool column_conflict # true if column already exists +int ip, ctowrd() +pointer tbtopn() +int tbtacc() + +begin + colunits[1,1] = EOS + colfmt[1,1] = EOS + + # Assign column names. + do i = 2, NCOLS { + call sprintf (cname[1,i], SZ_COLNAME, "%s%d") + call pargstr (c_root) + call pargi (i-1) + } + + # Replace commas with blanks in the user-specified format string. + ip = 1 + while (formats[ip] != EOS) { + if (formats[ip] == ',') + formats[ip] = ' ' + ip = ip + 1 + } + + # Assign print format and units. + ip = 1 + do i = 2, NCOLS { + + if (wcs_type == IMTAB_LOGICAL) { + + # If the user specified a format, use it; otherwise, + # assign a default. + if (ctowrd (formats, ip, colfmt[1,i], SZ_COLFMT) < 1) { + if (dtype[i] == TY_INT) + call strcpy ("%11d", colfmt[1,i], SZ_COLFMT) + else if (dtype[i] == TY_SHORT) + call strcpy ("%5d", colfmt[1,i], SZ_COLFMT) + } + call strcpy ("pixels", colunits[1,i], SZ_COLUNITS) + + } else if (wcs_type == IMTAB_PHYSICAL) { + + if (ctowrd (formats, ip, colfmt[1,i], SZ_COLFMT) < 1) + call strcpy ("%9.3f", colfmt[1,i], SZ_COLFMT) + call strcpy ("pixels", colunits[1,i], SZ_COLUNITS) + + } else if (wcs_type == IMTAB_WORLD) { + + if (ctowrd (formats, ip, colfmt[1,i], SZ_COLFMT) < 1) + colfmt[1,i] = EOS # take the default + colunits[1,i] = EOS # we don't know the units + + } else { + colfmt[1,i] = EOS + colunits[1,i] = EOS + } + } + + do i = 1, NCOLS { + lendat[i] = 1 + cp[i] = NULL + } + + nrows = 1 + do i = 1, IM_NDIM(im) + nrows = nrows * IM_LEN(im,i) + + # Does the table already exist? + new_table = (tbtacc (outtable) == NO) + + if (new_table) { + tp = tbtopn (outtable, NEW_FILE, NULL) + + if (ttype[1] == 'r') { + call tbpset (tp, TBL_WHTYPE, TBL_TYPE_S_ROW) + } else if (ttype[1] == 'c') { + call tbpset (tp, TBL_WHTYPE, TBL_TYPE_S_COL) + call tbpset (tp, TBL_ALLROWS, nrows) + } else if (ttype[1] == 't') { + call tbpset (tp, TBL_WHTYPE, TBL_TYPE_TEXT) + } + } else { + tp = tbtopn (outtable, READ_WRITE, NULL) + } + + # Make sure the columns don't already exist. + column_conflict = false + if ( ! new_table ) { + call tbcfnd (tp, cname, cp, ncols) + do i = 1, ncols { + if (cp[i] != NULL) { + call eprintf ("Column %s already exists.\n") + call pargstr (cname[1,i]) + column_conflict = true + } + } + if (column_conflict) { + call imunmap (im) + call tbtclo (tp) + call error (1, + "new columns in existing table must be unique") + } + } + + # Define the columns. + call tbcdef (tp, cp, cname, colunits, colfmt, dtype, lendat, ncols) + + if (new_table) + call tbtcre (tp) # open the file + + # Write history info. + call strcpy ("Column ", history, SZ_FNAME) + call strcat (cname[1,1], history, SZ_FNAME) # column name for data + call strcat (" from ", history, SZ_FNAME) + call strcat (IM_HDRFILE(im), history, SZ_FNAME) # name of input image + call tbhadt (tp, "history", history) + if (ncols > 1) { + call strcpy ("Column ", history, SZ_FNAME) + call strcat (cname[1,1], history, SZ_FNAME) + if (ncols > 2) + call strcat (", pixel columns ", history, SZ_FNAME) + else + call strcat (", pixel column ", history, SZ_FNAME) + do i = 2, ncols-1 { + call strcat (cname[1,i], history, SZ_FNAME) + call strcat (", ", history, SZ_FNAME) + } + call strcat (cname[1,ncols], history, SZ_FNAME) + call tbhadt (tp, "history", history) + } +end diff --git a/pkg/utilities/nttools/imtab/itbwcs.x b/pkg/utilities/nttools/imtab/itbwcs.x new file mode 100644 index 00000000..4ecea420 --- /dev/null +++ b/pkg/utilities/nttools/imtab/itbwcs.x @@ -0,0 +1,129 @@ +include +include +include "imtab.h" + +# This file contains three routines: itb_wcs_init and the single and +# double precision routines itb_ctranr & itb_ctrand. +# +# Phil Hodge, 30-Sep-1993 Subroutines created. + +# itb_wcs_init -- open wcs, etc +# This routine gets the wcs, turns axis mapping off, and initializes +# the transformation for physical or world coordinates. The dimension +# of the original image and the mapping from logical to physical axis +# numbers are returned for use by itb_ctrand and itb_ctranr. + +procedure itb_wcs_init (im, wcs_type, mw, ct, ax, wcsdim) + +pointer im # i: imhdr pointer for image +int wcs_type # i: wcs type +pointer mw, ct # o: mwcs pointers +int ax[IM_MAXDIM] # o: ax[i] is physical axis for logical axis i +int wcsdim # o: dimension of physical image coord system +#-- +int axno[IM_MAXDIM] # axno[j] is logical axis for physical axis j +int axval[IM_MAXDIM] # axval[j] is value if axno[j] is zero +int ndim # number of "logical" axes +int i, j +pointer mw_openim(), mw_sctran() +int mw_stati() + +begin + if (wcs_type == IMTAB_NO_WCS || wcs_type == IMTAB_LOGICAL) { + mw = NULL + ct = NULL + wcsdim = IM_NDIM(im) + return + } + + # Get the wcs. + mw = mw_openim (im) + + # Set up the transformation. + call mw_seti (mw, MW_USEAXMAP, NO) + if (wcs_type == IMTAB_PHYSICAL) + ct = mw_sctran (mw, "logical", "physical", 0) + else if (wcs_type == IMTAB_WORLD) + ct = mw_sctran (mw, "logical", "world", 0) + wcsdim = mw_stati (mw, MW_NPHYSDIM) + ndim = IM_NDIM(im) + + # Get the logical axis number corresponding to each physical axis. + call mw_gaxmap (mw, axno, axval, wcsdim) + + # Invert axno: get the physical axis number for each logical axis. + do i = 1, ndim # initialize + ax[i] = 0 + do j = 1, wcsdim { + do i = 1, ndim { + if (axno[j] == i) { + ax[i] = j + break + } + } + } + + # Check to be sure each axis was found. + do i = 1, ndim { + if (ax[i] < 1) + call error (1, "itb_mwcs_init: an axis was not found") + } +end + +# itb_ctran -- translate coordinates with axis mapping = NO +# This routine translates "logical" coordinates to "physical" or "world". +# Axis mapping must have been turned off, and the mapping from logical +# to physical axes is given by the array AX: if I is a logical axis +# number, AX[I] is the corresponding physical axis number. Each element +# of the array IN must have been initialized to one by the calling routine. +# Separate single and double precision versions are included. + +procedure itb_ctrand (im, ct, ax, in, incoords, outcoords, wcsdim) + +pointer im # i: imhdr pointer +pointer ct # i: coordinate transformation pointer +int ax[wcsdim] # i: "logical" to "physical" mapping +double in[IM_MAXDIM] # io: copy of incoords but includes axis mapping +double incoords[wcsdim] # i: input "logical" coordinates +double outcoords[wcsdim] # o: output coordinates +int wcsdim # i: length of incoords & outcoords arrays +#-- +int i + +begin + if (ct == NULL) { + call amovd (incoords, outcoords, wcsdim) + return + } + + # Take account of axis mapping; i is the logical axis number. + do i = 1, IM_NDIM(im) + in[ax[i]] = incoords[i] + + call mw_ctrand (ct, in, outcoords, wcsdim) +end + +procedure itb_ctranr (im, ct, ax, in, incoords, outcoords, wcsdim) + +pointer im # i: imhdr pointer +pointer ct # i: coordinate transformation pointer +int ax[wcsdim] # i: "logical" to "physical" mapping +real in[IM_MAXDIM] # io: copy of incoords but includes axis mapping +real incoords[wcsdim] # i: input "logical" coordinates +real outcoords[wcsdim] # o: output coordinates +int wcsdim # i: length of incoords & outcoords arrays +#-- +int i + +begin + if (ct == NULL) { + call amovr (incoords, outcoords, wcsdim) + return + } + + # Take account of axis mapping; i is the logical axis number. + do i = 1, IM_NDIM(im) + in[ax[i]] = incoords[i] + + call mw_ctranr (ct, in, outcoords, wcsdim) +end diff --git a/pkg/utilities/nttools/imtab/mkpkg b/pkg/utilities/nttools/imtab/mkpkg new file mode 100644 index 00000000..6e6431a0 --- /dev/null +++ b/pkg/utilities/nttools/imtab/mkpkg @@ -0,0 +1,13 @@ +# Update the imtab & tabim application code in the ttools package library. +# Author: HODGE, 31-DEC-1990 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + imtab.x "imtab.h" + itbwcs.x "imtab.h" + tabim.x + ; diff --git a/pkg/utilities/nttools/imtab/tabim.x b/pkg/utilities/nttools/imtab/tabim.x new file mode 100644 index 00000000..8a9e7211 --- /dev/null +++ b/pkg/utilities/nttools/imtab/tabim.x @@ -0,0 +1,176 @@ +include +include # to check whether input is redirected +include + +# tabim -- create an image from one column of a table +# This task copies a column of a table into an image. If the image already +# exists, it will be overwritten; otherwise, a new image will be created. +# For a new image, if the 'ndim' parameter is greater than zero, the size of +# the image will be taken from the parameters 'n1', 'n2', etc. It is the +# user's responsibility to ensure that the product of these values equals +# the number of rows in the table. +# +# Phil Hodge, 12-Oct-1989 Task created +# Phil Hodge, 11-Jan-1991 Allow multi-dimensional output. +# Phil Hodge, 15-May-1998 Check null flag, and replace INDEF with -999. +# Phil Hodge, 8-Jun-1999 Set input to STDIN if redirected. +# Phil Hodge, 30-Mar-2000 Allow lists of names for input and output. + +procedure tabim() + +pointer inlist, outlist # for input and output names +char intable[SZ_FNAME] # name of an input table +char output[SZ_FNAME] # name of an output image +char colname[SZ_COLNAME] # column name +int ndim # dimension of output image +int axlen[IM_MAXDIM] # length of each axis of output image +#-- +pointer sp # stack pointer for scratch space +pointer tp # pointer to descriptor for input table +pointer cp # column descriptor +pointer im # pointer to image descriptor +pointer xp # pointer to output data for image +pointer temp # scratch for parameter name +pointer nullflag # scratch for null flags (ignored) +long v[IM_MAXDIM] # for call to impnld() +int dtype # data type +int npix # number of pixels, accumulated one axis at a time +int nrows # number of rows in table +int nlines # number of lines in image +int frow, lrow # row number limits for tbcgtd +int i, k +int junk +bool new_image # true if the image does not already exist +pointer immap(), tbtopn() +int clgeti(), impnld(), imaccess() +int fstati() +int tbpsta(), tbcigi() + +pointer imt, tnt # pointers for filename templates +int nin, nout # numbers of names in lists +pointer imtopen(), tbnopen() +int imtlen(), imtgetim(), tbnlen(), tbnget() + +begin + call smark (sp) + call salloc (inlist, SZ_LINE, TY_CHAR) + call salloc (outlist, SZ_LINE, TY_CHAR) + call salloc (temp, SZ_FNAME, TY_CHAR) + + # Get the names of the input tables. + if (fstati (STDIN, F_REDIR) == YES) + call strcpy ("STDIN", Memc[inlist], SZ_FNAME) + else + call clgstr ("intable", Memc[inlist], SZ_FNAME) + tnt = tbnopen (Memc[inlist]) + nin = tbnlen (tnt) + + # Get the names of the output images. + call clgstr ("output", Memc[outlist], SZ_FNAME) + imt = imtopen (Memc[outlist]) + nout = imtlen (imt) + + if (nin == 0) + call error (1, "no input table specified") + if (nout == 0) + call error (1, "no output image specified") + if (nin != nout) + call error (1, "input and output lists must have the same length") + + call clgstr ("colname", colname, SZ_COLNAME) + + # ndim is either zero or the dimension for new output images. + ndim = clgeti ("ndim") + if (ndim < 1) + ndim = 1 + do k = 1, IM_MAXDIM # initial values + axlen[k] = 1 + # Get the length of all but the last axis. + do k = 1, ndim-1 { + call sprintf (Memc[temp], SZ_FNAME, "n%d") + call pargi (k) + axlen[k] = clgeti (Memc[temp]) + } + + # Loop over the list of input tables. + while (tbnget (tnt, intable, SZ_FNAME) != EOF) { + + junk = imtgetim (imt, output, SZ_FNAME) + + tp = tbtopn (intable, READ_ONLY, NULL) + call tbcfnd (tp, colname, cp, 1) # only one column name + if (cp == NULL) { + call tbtclo (tp) + call error (1, "column not found") + } + nrows = tbpsta (tp, TBL_NROWS) + + # Open the output image. + if (imaccess (output, READ_WRITE) == YES) { + new_image = false + im = immap (output, READ_WRITE, NULL) + } else { + new_image = true + im = immap (output, NEW_IMAGE, NULL) + } + + if (new_image) { + # Set the size of the new image. + IM_NDIM(im) = ndim + npix = 1 # initial value + do k = 1, ndim-1 { + IM_LEN(im,k) = axlen[k] + npix = npix * axlen[k] + } + axlen[ndim] = nrows / npix + IM_LEN(im,ndim) = axlen[ndim] + + # The image data type is the same as that of the column. + dtype = tbcigi (cp, TBL_COL_DATATYPE) + if (dtype == TY_BOOL) + dtype = TY_SHORT + IM_PIXTYPE(im) = dtype + } + + nlines = 1 # initial value + do k = 2, IM_NDIM(im) + nlines = nlines * IM_LEN(im,k) + if (IM_LEN(im,1) * nlines != nrows) { + call tbtclo (tp) + call imunmap (im) + if (new_image) { + call imdelete (output) + call error (1, + "specified axis lengths are not consistent with size of table") + } else { + call error (1, + "size of existing image is not consistent with size of table") + } + } + + # Allocate space for the array of null flags (which we ignore), + # one element for each pixel in a line. + call salloc (nullflag, IM_LEN(im,1), TY_BOOL) + + # Copy the column into the image, one line at a time. + do k = 1, IM_MAXDIM + v[k] = 1 + frow = 1 + lrow = IM_LEN(im,1) + do k = 1, nlines { + junk = impnld (im, xp, v) + call tbcgtd (tp, cp, Memd[xp], Memb[nullflag], frow, lrow) + do i = 0, lrow-frow { + if (Memb[nullflag+i]) + Memd[xp+i] = -999.d0 + } + frow = frow + IM_LEN(im,1) + lrow = lrow + IM_LEN(im,1) + } + + call imunmap (im) + call tbtclo (tp) + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/keypar.par b/pkg/utilities/nttools/keypar.par new file mode 100644 index 00000000..c379bec1 --- /dev/null +++ b/pkg/utilities/nttools/keypar.par @@ -0,0 +1,6 @@ +input,f,a,"",,,"Name of file containing header keyword" +keyword,s,a,"",,,"Name of header keyword" +silent,b,h,no,,,"Do not print any warning messages?" +value,s,h,"",,,"Value of header keyword" +found,b,h,no,,,"Was keyword found in header?" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/keyselect.par b/pkg/utilities/nttools/keyselect.par new file mode 100644 index 00000000..6302af1d --- /dev/null +++ b/pkg/utilities/nttools/keyselect.par @@ -0,0 +1,6 @@ +input,s,a,"",,,list of image names +output,s,a,"",,,output table name +cols,s,a,"",,,list of keyword and table column names +expr,s,h," ",,,boolean expression used to select images +cdfile,s,h," ",,,column description file name +mode,s,h,"al" diff --git a/pkg/utilities/nttools/keyselect/expr.x b/pkg/utilities/nttools/keyselect/expr.x new file mode 100644 index 00000000..fa7e5d31 --- /dev/null +++ b/pkg/utilities/nttools/keyselect/expr.x @@ -0,0 +1,193 @@ +include +include "keyselect.h" + +#* HISTORY * +#* B.Simon 12-Mar-1992 Original +#* Phil Hodge 4-Mar-2002 Free memory allocated by evexpr. + +# EVAL_EXPR -- Evaluate a boolean expression using image header keywords + +bool procedure eval_expr (im, expr) + +pointer im # i: image descriptor +char expr[ARB] # i: boolean expression +#-- +include "keyselect.com" + +pointer op, sp, errmsg + +string badtype "Expression is not of boolean type" +string badname "Warning: header keyword %s not found in %s\n" + +int errget() +pointer evexpr(), locpr() +extern fun_expr, var_expr + +begin + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + img = im + iferr { + op = evexpr (expr, locpr(var_expr), locpr (fun_expr)) + + } then { + if (errget(Memc[errmsg], SZ_LINE) == ERR_SYNTAX) { + call xer_reset + call error (ERR_SYNTAX, Memc[errmsg]) + + } else { + call xer_reset + call eprintf ("Warning: %s\n") + call pargstr (Memc[errmsg]) + call mfree (op, TY_STRUCT) + + return (false) + } + } + + if (O_TYPE(op) != TY_BOOL) + call error (ERR_SYNTAX, badtype) + + call xev_freeop (op) + call mfree (op, TY_STRUCT) + call sfree (sp) + return (O_VALB(op)) +end + +# FMT_EXPR -- Format an expression to make it easier to parse + +procedure fmt_expr (expr) + +char expr[ARB] # i: expression +#-- +int ic, jc + +begin + # Find first non-white character + + for (ic = 1; expr[ic] != EOS; ic = ic + 1) { + if (expr[ic] > ' ') + break + } + + # Copy remaining characters, replacing newlines with blanks + + jc = 1 + for ( ; expr[ic] != EOS; ic = ic + 1) { + if (expr[ic] == '\n') { + expr[jc] = ' ' + } else if (jc < ic) { + expr[jc] = expr[ic] + } + jc = jc + 1 + } + + expr[jc] = EOS +end + +# FUN_EXPR -- Evaluate non-standard functions used in expression + +procedure fun_expr (func, argptr, nargs, op) + +char func[ARB] # i: function name +pointer argptr[ARB] # i: pointers to function arguments +int nargs # i: number of function arguments +pointer op # o: structure containing function value +#-- +include "keyselect.com" + +int arg +pointer sp, errmsg + +string flist "find" +string badfun "Unknown function name (%s)" +string badtyp "Invalid argument type for %s" + +int word_match(), imaccf() + +begin + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + switch (word_match (func, flist)) { + case 0: # unrecognized function name + call sprintf (Memc[errmsg], SZ_LINE, badfun) + call pargstr (func) + call error (ERR_SYNTAX, Memc[errmsg]) + + case 1: # find keyword in header ? + call xev_initop (op, 0, TY_BOOL) + O_VALB(op) = true + + do arg = 1, nargs { + if (O_TYPE(argptr[arg]) != TY_CHAR) { + call sprintf (Memc[errmsg], SZ_LINE, badtyp) + call pargstr (func) + call error (ERR_SYNTAX, Memc[errmsg]) + } + + if (imaccf (img, O_VALC(argptr[arg])) == NO) + O_VALB(op) = false + } + } + + call sfree (sp) +end + +# VAR_EXPR -- Retrieve keyword used in expression + +procedure var_expr (name, op) + +char name[ARB] # i: keyword name +pointer op # o: structure containing value of variable +#-- +include "keyselect.com" + +int ic, dtype, type, length, junk +pointer sp, value + +string badname "Expression cannot be evaluated because keyword not found" + +bool streq() +int ctoi(), ctor() + +begin + call smark(sp) + call salloc (value, SZ_BIGCOL, TY_CHAR) + + # Retrieve keyword value from image header + + call get_keyword (img, name, dtype, Memc[value], SZ_BIGCOL) + + # Allocate structure to hold value + + if (dtype == 0) { + call error (ERR_NOFIND, badname) + } else if (dtype < 0) { + type = TY_CHAR + length = - dtype + } else { + type = dtype + length = 0 + } + + call xev_initop (op, length, type) + + # Copy value to structure + + switch (type) { + case TY_BOOL: + O_VALB(op) = streq (Memc[value], "yes") + case TY_CHAR: + call strcpy (Memc[value], O_VALC(op), length) + case TY_SHORT,TY_INT,TY_LONG: + ic = 1 + junk = ctoi (Memc[value], ic, O_VALI(op)) + case TY_REAL,TY_DOUBLE: + ic = 1 + junk = ctor (Memc[value], ic, O_VALR(op)) + } + + call sfree(sp) +end diff --git a/pkg/utilities/nttools/keyselect/keyselect.com b/pkg/utilities/nttools/keyselect/keyselect.com new file mode 100644 index 00000000..fc0e63b5 --- /dev/null +++ b/pkg/utilities/nttools/keyselect/keyselect.com @@ -0,0 +1,9 @@ +# KEYSELECT.COM -- Global variables used by keyselect + +#* HISTORY * +#* B.Simon 12-Mar-92 Original + +common /global/ hasgroup, img + +bool hasgroup # true if image has group parameters +pointer img # image descriptor diff --git a/pkg/utilities/nttools/keyselect/keyselect.h b/pkg/utilities/nttools/keyselect/keyselect.h new file mode 100644 index 00000000..ef001849 --- /dev/null +++ b/pkg/utilities/nttools/keyselect/keyselect.h @@ -0,0 +1,17 @@ +# KEYSELECT.H -- Global constants used by keyselect + +#* HISTORY * +#* B.Simon 12-Mar-92 Original + +define SZ_STRCOL 19 +define SZ_BIGCOL 63 + +define ERR_SYNTAX 1 +define ERR_NOFIND 2 + +define ASSIGN_CHAR '=' +define CONCAT_CHAR ':' +define SEP_CHAR ',' + +define IS_SEP ($1 <= ' ' || $1 == ',') + diff --git a/pkg/utilities/nttools/keyselect/keyselect.x b/pkg/utilities/nttools/keyselect/keyselect.x new file mode 100644 index 00000000..2bc8a72e --- /dev/null +++ b/pkg/utilities/nttools/keyselect/keyselect.x @@ -0,0 +1,122 @@ +# KEYSELECT -- Copy selected image header keywords to sdas table + +#* HISTORY * +#* B.Simon 12-Mar-1992 Original +# Phil Hodge 8-Apr-1999 Call tbfpri. + +procedure keyselect () + +#-- +include "keyselect.com" + +pointer input # list of image names +pointer output # sdas table name +pointer cols # list of keyword and table column names +pointer expr # boolean expression used to select images +pointer cdfile # column description file + +bool first +int ngroup +int phu_copied # set by tbfpri and ignored +pointer sp, keywords, columns, cluster, image +pointer imlist, grplist, colptr, im, tp + +string noread "No images read. Output table not created." + +bool tp_fetch(), eval_expr() +int imtgetim() +pointer imtopen(), immap(), tp_open(), op_table() + +begin + # Allocate dynamic memory for strings + + call smark(sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (cols, SZ_COMMAND, TY_CHAR) + call salloc (expr, SZ_COMMAND, TY_CHAR) + call salloc (cdfile, SZ_FNAME, TY_CHAR) + + call salloc (keywords, SZ_COMMAND, TY_CHAR) + call salloc (columns, SZ_COMMAND, TY_CHAR) + call salloc (cluster, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + + # Read task parameters + + call clgstr ("input", Memc[input], SZ_FNAME) + call clgstr ("output", Memc[output], SZ_FNAME) + call clgstr ("cols", Memc[cols], SZ_FNAME) + call clgstr ("expr", Memc[expr], SZ_FNAME) + call clgstr ("cdfile", Memc[cdfile], SZ_FNAME) + + # If keyword list or expression is contained in a file, read the file + + if (Memc[cols] == '@') + call rd_list (Memc[cols+1], Memc[cols], SZ_COMMAND) + call fmt_list (Memc[cols]) + + if (Memc[expr] == '@') + call rd_list (Memc[expr+1], Memc[expr], SZ_COMMAND) + call fmt_expr (Memc[expr]) + + # Separate out the header keyword and table column names + + call sep_list (Memc[cols], Memc[keywords], Memc[columns], SZ_COMMAND) + + # Loop over all images and all groups in image + + first = true + imlist = imtopen (Memc[input]) + + while (imtgetim (imlist, Memc[cluster], SZ_FNAME) != EOF) { + + # Hasgroup is set to true to get us through the loop the + # first time. It then is set to false, but can be set to + # true if either eval_expr() or cpy_table() accesses a + # group parameter. + + hasgroup = true + grplist = tp_open (Memc[cluster], 0, ngroup) + + while (hasgroup && tp_fetch (grplist, Memc[image])) { + im = immap (Memc[image], READ_ONLY, 0) + hasgroup = false + + # Open output table first time through loop + + if (first) { + first = false + call tbfpri (Memc[cluster], Memc[output], phu_copied) + tp = op_table (im, Memc[output], Memc[keywords], + Memc[columns], Memc[cdfile]) + call rd_table (Memc[columns], tp, colptr) + } + + # Copy keywords from header to table if expression is true + + if (Memc[expr] == EOS) { + call cpy_table (im, tp, colptr, Memc[keywords]) + } else if (eval_expr (im, Memc[expr])) { + call cpy_table (im, tp, colptr, Memc[keywords]) + } + + call imunmap (im) + } + call tp_close (grplist) + } + + # Close files and release memory + + call imtclose (imlist) + call sfree(sp) + + if (first) { + call eprintf (noread) + + } else { + call mfree (colptr, TY_POINTER) + call tbtclo (tp) + } + +end diff --git a/pkg/utilities/nttools/keyselect/keyword.x b/pkg/utilities/nttools/keyselect/keyword.x new file mode 100644 index 00000000..b360e7cd --- /dev/null +++ b/pkg/utilities/nttools/keyselect/keyword.x @@ -0,0 +1,253 @@ +include +include +include "keyselect.h" + +#* HISTORY * +#* B.Simon 12-Mar-92 Original + +# GET_KEYWORD -- Get the keyword from the image header + +procedure get_keyword (im, name, dtype, value, maxch) + +pointer im # i: image descriptor +char name[ARB] # i: keyword name +int dtype # o: keyword data type +char value[ARB] # o: keyword value +int maxch # i: maximum length of value string +#-- +include "keyselect.com" + +string badname "Warning: header keyword %s not found in %s\n" + +int imgftype(), gf_gfind() + +begin + # Any name beginning with a $ is a special keyword + + if (name[1] == '$') { + call spec_keyword (im, name, dtype, value, maxch) + + } else { + # Get the data type of the header keyword + # If the keyword is not found set the data type to + # zero to indicate this and return + + iferr { + dtype = imgftype (im, name) + } then { + call eprintf (badname) + call pargstr (name) + call pargstr (IM_HDRFILE(im)) + + dtype = 0 + value[1] = EOS + return + } + + if (dtype == TY_SHORT || dtype == TY_LONG) + dtype = TY_INT + if (dtype == TY_CHAR) + dtype = - maxch + + # Read header keyword from image. This procedure sets hasgroup + # to true if asked to retrieve a group parameter + + call imgstr (im, name, value, maxch) + if (dtype == TY_BOOL) { + if (value[1] == 'T') { + call strcpy ("yes", value, maxch) + } else { + call strcpy ("no", value, maxch) + } + } + + if (gf_gfind (im, name) > 0) + hasgroup = true + } + +end + +# NAME_KEYWORD -- Retrieve the default column name for a special keyword + +procedure name_keyword (name, colname, maxch) + +char name[ARB] # i: keyword name +char colname[ARB] # o: default column name +int maxch # i: maximum length of column name +#-- +int idx, junk +pointer sp, errmsg + +string special "group,dir,ext,hdr,pix,root" +string defaults "group,directory,extension,header_file,data_file,rootname" +string badname "Name for special keyword not recognized (%s)" + +int word_match(), word_find() + +begin + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + if (name[1] != '$') { + call strcpy (name, colname, maxch) + return + } + + # Get the index of special keyword name in the list + # The find the corresponding name in the list of defaults + + idx = word_match (name[2], special) + if (idx == 0) { + call sprintf (Memc[errmsg], SZ_LINE, badname) + call pargstr (name) + call error (1, Memc[errmsg]) + } else { + junk = word_find (idx, defaults, colname, maxch) + } + + call sfree (sp) +end + +# SPEC_KEYWORD -- Get the value of a special keyword + +procedure spec_keyword (im, name, dtype, value, maxch) + +pointer im # i: image descriptor +char name[ARB] # i: keyword name +int dtype # o: keyword data type +char value[ARB] # o: keyword value +int maxch # i: maximum length of value string +#-- +include "keyselect.com" + +int match, ival, junk +pointer sp, image, ldir, root, errmsg, hdr, ext + +string int_special "group" +string str_special "dir,ext,hdr,pix,root" + +string badname "Name for special keyword not recognized (%s)" +string badimgext "Image extension not recognized (%s)" + +bool streq() +int word_match(), fnldir(), fnroot(), itoc() + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (ldir, SZ_FNAME, TY_CHAR) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Search lists for special keyword + + match = - word_match (name[2], int_special) + if (match == 0) + match = word_match (name[2], str_special) + + # Data type is determined from which list it is on + + if (match < 0) { + dtype = TY_INT + } else if (match > 0) { + dtype = - maxch + } else { + call sprintf (Memc[errmsg], SZ_LINE, badname) + call pargstr (name) + call error (1, Memc[errmsg]) + } + + # Break image name into its component parts + + if (match > 0) { + call imgcluster (IM_HDRFILE(im), Memc[image], SZ_FNAME) + + hdr = image + fnldir (Memc[image], Memc[ldir], SZ_FNAME) + ext = hdr + 1 + fnroot (Memc[hdr], Memc[root], SZ_FNAME) + } + + + # Get value of special keyword + + switch (match) { + case -1: + # group number $group + hasgroup = true + ival = max (1, IM_CLINDEX(im)) + junk = itoc (ival, value, maxch) + case 0: + # (not used) + ; + case 1: + # directory name $dir + call strcpy (Memc[ldir], value, maxch) + case 2: + # extension $ext + call strcpy (Memc[ext], value, maxch) + case 3: + # header file name $hdr + call strcpy (Memc[hdr], value, maxch) + case 4: + # pixel file name $pix + if (Memc[ext+2] != 'h' || Memc[ext+3] != EOS) { + call sprintf (Memc[errmsg], SZ_LINE, badimgext) + call pargstr (Memc[hdr]) + call error (1, Memc[errmsg]) + } + + call strcpy (Memc[root], value, maxch) + if (streq (Memc[ext], "imh")) { + call strcat (".pix", value, maxch) + } else { + Memc[ext+2] = 'd' + call strcat (".", value, maxch) + call strcat (Memc[ext], value, maxch) + } + case 5: + # root name $root + call strcpy (Memc[root], value, maxch) + } + + call sfree (sp) +end + +# TYPE_KEYWORD -- Retrieve the type of a special keyword + +int procedure type_keyword (name) + +char name[ARB] # i: special keyword name +#-- +int dtype +pointer sp, errmsg + +string int_special "group" +string str_special "dir,ext,hdr,pix,root" +string badname "Name for special keyword not recognized (%s)" + +int word_match() + +begin + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + if (name[1] != '$') { + call sprintf (Memc[errmsg], SZ_LINE, badname) + call pargstr (name) + call error (1, Memc[errmsg]) + + } else if (word_match (name[2], int_special) > 0) { + dtype = TY_INT + + } else if (word_match (name[2], str_special) > 0) { + dtype = TY_CHAR + + } else { + call sprintf (Memc[errmsg], SZ_LINE, badname) + call pargstr (name) + call error (1, Memc[errmsg]) + } + + call sfree (sp) + return (dtype) +end + diff --git a/pkg/utilities/nttools/keyselect/list.x b/pkg/utilities/nttools/keyselect/list.x new file mode 100644 index 00000000..b25e1a7e --- /dev/null +++ b/pkg/utilities/nttools/keyselect/list.x @@ -0,0 +1,215 @@ +include "keyselect.h" + +#* HISTORY * +#* B.Simon 12-Mar-92 Original + +# BRK_LIST -- Retrieve a string from the list + +int procedure brk_list (list, ic, sep, str, maxch) + +char list[ARB] # i: list of items +int ic # u: index into list +char sep # i: character separating strings in the list +char str[ARB] # o: output string +int maxch # i: maximum length of output string +#-- +int jc + +begin + # Copy characters into output string until separation character + # or end of list is found + + for (jc = 1; jc <= maxch; jc = jc + 1) { + str[jc] = list[ic] + ic = ic + 1 + + if (str[jc] == sep) { + break + } else if (str[jc] == EOS) { + ic = ic - 1 # back up to EOS character + break + } + } + + str[jc] = EOS + return (jc-1) +end + +# CNT_LIST -- Count the number of items in a list + +int procedure cnt_list (list) + +char list[ARB] # i: list of items +#-- +int ic, count + +begin + # Number of items is number of separation characters plus one + + count = 1 + for (ic = 1; list[ic] != EOS; ic = ic + 1) { + if (list[ic] == SEP_CHAR) + count = count + 1 + } + + return (count) +end + +# FMT_LIST -- Format a list into canonical form + +procedure fmt_list (list) + +char list[ARB] # u: list of keyword names +#-- +bool tween +int ic, jc + +begin + jc = 1 + tween = true + + # Eliminate consecutive separation characters between list items + + for (ic = 1; list[ic] != EOS; ic = ic + 1) { + if (IS_SEP(list[ic])) { + if (! tween) { + tween = true + list[jc] = SEP_CHAR + jc = jc + 1 + } + + } else { + tween = false + if (jc < ic) + list[jc] = list[ic] + jc = jc + 1 + } + } + + # Eliminate trailing separation character + + if (! tween || jc == 1) { + list[jc] = EOS + } else { + list[jc-1] = EOS + } + +end + +# RD_LIST -- Read values from a file into a list + +procedure rd_list (fname, list, maxch) + +char fname[ARB] # i: file containing list +char list[ARB] # o: output list +int maxch # i: maximum length of list +#-- +int fd, ic, nc + +int open(), getline() + +begin + # Concatenate contents of the file into a single long string + # while preserving the newlines between them + + fd = open (fname, READ_ONLY, TEXT_FILE) + + for (ic = 1; ic < maxch; ic = ic + nc) { + nc = getline (fd, list[ic]) + if (nc <= 0) + break + } + + list[ic] = EOS + call close (fd) + +end + +# SEP_LIST -- Separate list into keywords and table column names + +procedure sep_list (list, keywords, columns, maxch) + +char list[ARB] # i: combined list of columns and keywords +char keywords[ARB] # o: list of header keyword names +char columns[ARB] # o: list of table column names +int maxch # i: declared length of output strings +#-- +char eq, sep, cat +int ic, jc, kc, mc, nc +pointer sp, word, key, col + +data eq / ASSIGN_CHAR / +data sep / SEP_CHAR / +data cat / CONCAT_CHAR / + +string nolist "List of header keywords is empty. No table created." + +int stridx(), gstrcpy(), brk_list() + +begin + call smark(sp) + call salloc (word, SZ_LINE, TY_CHAR) + call salloc (key, SZ_LINE, TY_CHAR) + call salloc (col, SZ_LINE, TY_CHAR) + + ic = 1 + jc = 1 + kc = 1 + + # Extract the next item from the combined list of columns and keywords + + while (brk_list (list, ic, sep, Memc[word], SZ_LINE) > 0) { + + # Break the item into the column and keyword names + # If both are not given in the item assume they are the same + + nc = stridx (eq, Memc[word]) + if (nc > 0) { + Memc[word+nc-1] = EOS + call strcpy (Memc[word], Memc[col], SZ_LINE) + call strcpy (Memc[word+nc], Memc[key], SZ_LINE) + + } else { + call strcpy (Memc[word], Memc[col], SZ_LINE) + call strcpy (Memc[word], Memc[key], SZ_LINE) + + # Translate keyword names into their default column names + # and substitute underscores for the concatenation char + + if (Memc[col] == '$') { + call name_keyword (Memc[col], Memc[col], SZ_LINE) + + } else { + repeat { + mc = stridx (cat, Memc[col]) + if (mc == 0) + break + + Memc[col+mc-1] = '_' + } + } + } + + # Append keyword and column name to output string + + jc = jc + gstrcpy (Memc[key], keywords[jc], maxch-jc) + keywords[jc] = SEP_CHAR + jc = jc + 1 + + kc = kc + gstrcpy (Memc[col], columns[kc], maxch-kc) + columns[kc] = SEP_CHAR + kc = kc + 1 + } + + # Exit with error if either list is empty + + if (jc == 1 || kc == 1) + call error (1, nolist) + + # Eliminate trailing separation character + + keywords[jc-1] = EOS + columns[kc-1] = EOS + + call sfree(sp) +end diff --git a/pkg/utilities/nttools/keyselect/mkpkg b/pkg/utilities/nttools/keyselect/mkpkg new file mode 100644 index 00000000..d22d2201 --- /dev/null +++ b/pkg/utilities/nttools/keyselect/mkpkg @@ -0,0 +1,15 @@ +# Update the keyselect application code in the ttools package library +# Author: B.Simon, 12-Mar-92 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + expr.x "keyselect.h" + keyselect.x "keyselect.com" + keyword.x "keyselect.h" "keyselect.com" + list.x "keyselect.h" + tab.x "keyselect.h" + ; diff --git a/pkg/utilities/nttools/keyselect/tab.x b/pkg/utilities/nttools/keyselect/tab.x new file mode 100644 index 00000000..1e4dd769 --- /dev/null +++ b/pkg/utilities/nttools/keyselect/tab.x @@ -0,0 +1,353 @@ +include +include +include "keyselect.h" + +#* HISTORY * +#* B.Simon 12-Mar-92 Original + +# CPY_TABLE -- Copy keywords from header to table row + +procedure cpy_table (im, tp, colptr, keywords) + +pointer im # i: image descriptor +pointer tp # i: table descriptor +pointer colptr # i: pointer to array of column descriptors +char keywords # i: list of header keywords +#-- +char cat, sep +int row, dtype, ic, jc, kc +pointer sp, cp, nlist, vlist, name, value + +data cat / CONCAT_CHAR / +data sep / SEP_CHAR / + +string nocolumn "cpy_table: not enough columns to store keywords" + +int tbpsta(), brk_list(), stridx(), gstrcpy() + +begin + call smark(sp) + call salloc (nlist, SZ_LINE, TY_CHAR) + call salloc (vlist, SZ_LINE, TY_CHAR) + call salloc (name, SZ_LINE, TY_CHAR) + call salloc (value, SZ_LINE, TY_CHAR) + + ic = 1 + cp = colptr + row = tbpsta (tp, TBL_NROWS) + 1 + + # Extract each keyword from the list of keywords + + while (brk_list (keywords, ic, sep, Memc[nlist], SZ_LINE) > 0) { + + # If the keyword is not a list of concatenated keywords + # copy its value into a string + + if (stridx (cat, Memc[nlist]) == 0) { + call get_keyword (im, Memc[nlist], dtype, + Memc[vlist], SZ_LINE) + + # Otherwise break the list of concatenated keywords + # and concatenate their values into a string + + } else { + jc = 1 + kc = 0 + while (brk_list (Memc[nlist], jc, cat, + Memc[name], SZ_LINE) > 0){ + + call get_keyword (im, Memc[name], dtype, + Memc[value], SZ_LINE) + + if (dtype != 0) { + kc = kc + gstrcpy (Memc[value], Memc[vlist+kc], + SZ_LINE-kc) + Memc[vlist+kc] = SEP_CHAR + kc = kc + 1 + } + } + kc = max (kc, 1) + Memc[vlist+kc-1] = EOS + } + + # Write the value into the table + + if (Memi[cp] == NULL) + call error (1, nocolumn) + + call tbeptt (tp, Memi[cp], row, Memc[vlist]) + cp = cp + 1 + } + + call sfree(sp) +end + +# FMT_TABLE -- Retrieve column format from column description file + +procedure fmt_table (cd, col, units, fmt, dtype) + +int cd # i: file descriptor of column description file +char col[ARB] # i: name of column to retrieve information for +char units[ARB] # o: column units +char fmt[ARB] # o: column format +int dtype # o: column data type +#-- +char star, comment +bool match +int idx, junk, length, typevals[5] +pointer sp, line, input, name, type, ftnfmt, errmsg + +string typestr "rdibc" +string badtype "Illegal datatype for column %s (%s)" +string badname "Warning: column not found in column description file (%s)\n" + +data star / '*' / +data comment / '#' / +data typevals /TY_REAL, TY_DOUBLE, TY_INT, TY_BOOL, TY_CHAR / + +bool streq() +int getline(), stridx(), ctoi + +begin + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + call salloc (input, SZ_COLNAME, TY_CHAR) + call salloc (name, SZ_COLNAME, TY_CHAR) + call salloc (type, SZ_COLFMT, TY_CHAR) + call salloc (ftnfmt, SZ_COLFMT, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + call strcpy (col, Memc[input], SZ_COLNAME) + call strlwr (Memc[input]) + + match = false + call seek (cd, BOF) + while (! match && getline (cd, Memc[line]) != EOF) { + + # Remove trailing comments from line + + idx = stridx (comment, Memc[line]) + if (idx > 0) + Memc[line+idx-1] = EOS + + # Column name is the first word on the line + + call sscan (Memc[line]) + call gargwrd (Memc[name], SZ_COLNAME) + call strlwr (Memc[name]) + + # If the name matches the procedure argument + # read the remaining fields on the line + + match = streq (Memc[input], Memc[name]) + if (match) { + call gargwrd (Memc[type], SZ_COLFMT) + call gargwrd (Memc[ftnfmt], SZ_COLFMT) + call gargwrd (units, SZ_COLUNITS) + + call strlwr (Memc[type]) + call tbbftp (Memc[ftnfmt], fmt) + + # Convert the type string to the corresponding integer value + + if (Memc[type] == EOS) { + dtype = 0 + + } else { + idx = stridx (Memc[type], typestr) + if (idx == 0) { + call sprintf (Memc[errmsg], SZ_LINE, badtype) + call pargstr (Memc[name]) + call pargstr (Memc[type]) + call error (1, Memc[errmsg]) + } + + dtype = typevals[idx] + if (dtype == TY_CHAR) { + idx = stridx (star, Memc[type]) + if (idx > 0) { + idx = idx + 1 + junk = ctoi (Memc[type], idx, length) + if (length > 0) + dtype = - length + } + } + } + + } + } + + # Send warning message and set defaults if no match + + if (! match) { + dtype = 0 + fmt[1] = EOS + units[1] = EOS + + call eprintf (badname) + call pargstr (col) + } + + call sfree (sp) +end + +# OP_TABLE -- Open the output table + +pointer procedure op_table(im, output, keywords, columns, cdfile) + +pointer im # i: image descriptor +char output[ARB] # i: table name +char keywords[ARB] # i: list of header keywords +char columns[ARB] # i: list of column names +char cdfile[ARB] # i: optional column description file +#-- +bool append +char sep, cat +int ic, jc, dtype +pointer sp, tp, cp, cd, col, key, units, fmt, errmsg + +data sep / SEP_CHAR / +data cat / CONCAT_CHAR / + +string nocolumn "Column not found in existing output table (%s)" +string nokeyword "op_table: no matching keyword for column" +string notfound "Warning: keyword not found when creating table (%s)\n" + +bool isblank() +int open(), stridx(), imgftype(), brk_list(), type_keyword() +pointer tbtopn() + +begin + call smark (sp) + call salloc (col, SZ_COLNAME, TY_CHAR) + call salloc (key, SZ_LINE, TY_CHAR) + call salloc (units, SZ_COLUNITS, TY_CHAR) + call salloc (fmt, SZ_COLFMT, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Open column description file + + if (isblank (cdfile)) { + cd = NULL + } else { + cd = open (cdfile, READ_ONLY, TEXT_FILE) + } + + # Append rows to the table if the table already exists + # otherwise create a new table + + append = true + iferr (tp = tbtopn (output, READ_WRITE, NULL)) { + append = false + tp = tbtopn (output, NEW_FILE, NULL) + } + + ic = 1 + jc = 1 + while (brk_list (columns, ic, sep, Memc[col], SZ_COLNAME) > 0) { + + if (brk_list (keywords, jc, sep, Memc[key], SZ_LINE) == 0) + call error (1, nokeyword) + + # Verify that the columns exist if we are in append mode + # Define the new columns if we are not + + if (append) { + call tbcfnd (tp, Memc[col], cp, 1) + if (cp == NULL) { + call sprintf (Memc[errmsg], SZ_LINE, nocolumn) + call pargstr (Memc[col]) + call error (1, Memc[errmsg]) + } + + } else { + # Get column characteristics from the column description file + # or use defaults and image header keyword type + + if (cd != NULL) + call fmt_table (cd, Memc[col], + Memc[units], Memc[fmt], dtype) + + if (cd == NULL || dtype == 0) { + Memc[units] = EOS + Memc[fmt] = EOS + + if (stridx (cat, Memc[key]) != 0) { + dtype = - SZ_BIGCOL + + } else if (Memc[key] == '$'){ + dtype = type_keyword (Memc[key]) + + } else { + iferr { + dtype = imgftype (im, Memc[key]) + } then { + dtype = 0 + call eprintf (notfound) + call pargstr (Memc[key]) + } + } + } + + if (dtype == 0 || dtype == TY_CHAR) + dtype = - SZ_STRCOL + if (dtype == TY_SHORT || dtype == TY_LONG) + dtype = TY_INT + if (dtype == TY_REAL) + dtype = TY_DOUBLE + + call tbcdef (tp, cp, Memc[col], Memc[units], Memc[fmt], + dtype, 1, 1) + } + } + + # Create the new table if not in append mode + + if (! append) + call tbtcre (tp) + + call sfree (sp) + return (tp) +end + +# RD_TABLE -- Create an array of column pointers from the list of column names + +procedure rd_table (columns, tp, colptr) + +char columns[ARB] # i: list of column names +pointer tp # i: table descriptor +pointer colptr # o: pointer to array of column names +#-- +char sep +int nptr, ic +pointer sp, cp, col, errmsg + +data sep / SEP_CHAR / +string nocolumn "rd_table: column not found (%s)" + +int cnt_list(), brk_list() + +begin + call smark (sp) + call salloc (col, SZ_LINE, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + nptr = cnt_list (columns) + 1 + call malloc (colptr, nptr, TY_POINTER) + + ic = 1 + cp = colptr + while (brk_list (columns, ic, sep, Memc[col], SZ_LINE) > 0) { + call tbcfnd (tp, Memc[col], Memi[cp], 1) + if (cp == NULL) { + call sprintf (Memc[errmsg], SZ_LINE, nocolumn) + call pargstr (Memc[col]) + + call error (1, Memc[errmsg]) + } + cp = cp + 1 + } + + Memi[cp] = NULL + call sfree(sp) +end diff --git a/pkg/utilities/nttools/keytab.par b/pkg/utilities/nttools/keytab.par new file mode 100644 index 00000000..3aaa5a67 --- /dev/null +++ b/pkg/utilities/nttools/keytab.par @@ -0,0 +1,7 @@ +input,f,a,"",,,"Name of file containing header keyword" +keyword,s,a,"",,,"Name of header keyword" +table,f,a,"",,,"Name of table" +column,s,a,"",,,"Name of column" +row,i,a,,1,,"Number of row" +silent,b,h,no,,,"Do not print any warning messages?" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/lib/allcols.x b/pkg/utilities/nttools/lib/allcols.x new file mode 100644 index 00000000..64e49786 --- /dev/null +++ b/pkg/utilities/nttools/lib/allcols.x @@ -0,0 +1,29 @@ +include + +# ALLCOLS -- Return a pointer to an array containing the indices of all +# the columns in a table. The calling procedure must free the array when it +# is through with it. +# +# B.Simon 11-Dec-87 First Code + +procedure allcolumns (tp, numcol, colptr) + +pointer tp # i: Table descriptor +int numcol # o: Number of columns in the table +pointer colptr # o: Pointer to array of indices + +int icol + +int tbpsta(), tbcnum() + +errchk tbpsta, malloc + +begin + + numcol = tbpsta (tp, TBL_NCOLS) + call malloc (colptr, numcol, TY_INT) + + do icol = 1, numcol + Memi[colptr+icol-1] = tbcnum (tp, icol) + +end diff --git a/pkg/utilities/nttools/lib/allrows.x b/pkg/utilities/nttools/lib/allrows.x new file mode 100644 index 00000000..086e6a4a --- /dev/null +++ b/pkg/utilities/nttools/lib/allrows.x @@ -0,0 +1,29 @@ +include + +# ALLROWS -- Return a pointer to an array containing the indices of all +# the rows in a table. The calling procedure must free the array when it +# is through with it. +# +# B.Simon 11-Dec-87 First Code + +procedure allrows (tp, numrow, rowptr) + +pointer tp # i: Table descriptor +int numrow # o: Number of rows in the table +pointer rowptr # o: Pointer to array of indices + +int irow + +int tbpsta() + +errchk tbpsta, malloc + +begin + + numrow = tbpsta (tp, TBL_NROWS) + call malloc (rowptr, numrow, TY_INT) + + do irow = 1, numrow + Memi[rowptr+irow-1] = irow + +end diff --git a/pkg/utilities/nttools/lib/compare.com b/pkg/utilities/nttools/lib/compare.com new file mode 100644 index 00000000..546e7222 --- /dev/null +++ b/pkg/utilities/nttools/lib/compare.com @@ -0,0 +1,7 @@ +# Variables needed by comparison routines used by the sort routines + +int lendata # length of a data element in units of its type +pointer dataptr # pointer to the beginning of array holding + # data to be sorted + +common /compare/ lendata, dataptr diff --git a/pkg/utilities/nttools/lib/compare.x b/pkg/utilities/nttools/lib/compare.x new file mode 100644 index 00000000..b05a50c1 --- /dev/null +++ b/pkg/utilities/nttools/lib/compare.x @@ -0,0 +1,258 @@ +.help compare +.nf___________________________________________________________________________ + +Comparison routines used to sort table columns. There are two sets of routines, +compasc[bdirt] for sorting in ascending order and compdsc[bdirt] for sorting in +descending order. The last letter indicates the type of data compared in the +sort. All routines return an integer that indicates the results of comparison. +The value of the integer is set according to the following scheme: + + Ascending Descending + + if mem[i] < mem[j], order = -1 if mem[i] > mem[j], order = -1 + if mem[i] == mem[j], order = 0 if mem[i] == mem[j], order = 0 + if mem[i] > mem[j], order = 1 if mem[i] < mem[j], order = 1 + +.endhelp_______________________________________________________________________ + +# B.Simon 16-Sept-87 First Code + +# COMPASCB -- Boolean comparison routine used for sort in ascending order + +int procedure compascb (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +begin + # false < true + + if (! Memb[dataptr+i-1] && Memb[dataptr+j-1]) + order = -1 + else if (Memb[dataptr+i-1] && ! Memb[dataptr+j-1]) + order = 1 + else + order = 0 + + return (order) +end + +# COMPASCD -- Double comparison routine used for sort in ascending order + +int procedure compascd (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +begin + + if (Memd[dataptr+i-1] < Memd[dataptr+j-1]) + order = -1 + else if (Memd[dataptr+i-1] > Memd[dataptr+j-1]) + order = 1 + else + order = 0 + + return (order) +end + +# COMPASCI -- Integer comparison routine used for sort in ascending order + +int procedure compasci (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +begin + + if (Memi[dataptr+i-1] < Memi[dataptr+j-1]) + order = -1 + else if (Memi[dataptr+i-1] > Memi[dataptr+j-1]) + order = 1 + else + order = 0 + + return (order) +end + +# COMPASCR -- Real comparison routine used for sort in ascending order + +int procedure compascr (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +begin + + if (Memr[dataptr+i-1] < Memr[dataptr+j-1]) + order = -1 + else if (Memr[dataptr+i-1] > Memr[dataptr+j-1]) + order = 1 + else + order = 0 + + return (order) +end + +# COMPASCT -- Text comparison routine used for sort in ascending order + +int procedure compasct (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +bool strlt(), strgt() + +begin + + if (strlt (Memc[dataptr+(i-1)*(lendata+1)], + Memc[dataptr+(j-1)*(lendata+1)]) ) + order = -1 + else if (strgt (Memc[dataptr+(i-1)*(lendata+1)], + Memc[dataptr+(j-1)*(lendata+1)]) ) + order = 1 + else + order = 0 + + return (order) +end + +# COMPDSCB -- Boolean comparison routine used for sort in descending order + +int procedure compdscb (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +begin + # true > false + + if (Memb[dataptr+i-1] && ! Memb[dataptr+j-1]) + order = -1 + else if (! Memb[dataptr+i-1] && Memb[dataptr+j-1]) + order = 1 + else + order = 0 + + return (order) +end + +# COMPDSCD -- Double comparison routine used for sort in descending order + +int procedure compdscd (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +begin + + if (Memd[dataptr+i-1] > Memd[dataptr+j-1]) + order = -1 + else if (Memd[dataptr+i-1] < Memd[dataptr+j-1]) + order = 1 + else + order = 0 + + return (order) +end + +# COMPDSCI -- Integer comparison routine used for sort in descending order + +int procedure compdsci (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +begin + + if (Memi[dataptr+i-1] > Memi[dataptr+j-1]) + order = -1 + else if (Memi[dataptr+i-1] < Memi[dataptr+j-1]) + order = 1 + else + order = 0 + + return (order) +end + +# COMPDSCR -- Real comparison routine used for sort in descending order + +int procedure compdscr (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +begin + + if (Memr[dataptr+i-1] > Memr[dataptr+j-1]) + order = -1 + else if (Memr[dataptr+i-1] < Memr[dataptr+j-1]) + order = 1 + else + order = 0 + + return (order) +end + +# COMPDSCT -- Text comparison routine used for sort in descending order + +int procedure compdsct (i, j) + +int i # i: Index to first array element in comparison +int j # i: Index to second element in comparison +#-- +include "compare.com" + +int order + +bool strgt(), strlt() + +begin + + if (strgt (Memc[dataptr+(i-1)*(lendata+1)], + Memc[dataptr+(j-1)*(lendata+1)]) ) + order = -1 + else if (strlt (Memc[dataptr+(i-1)*(lendata+1)], + Memc[dataptr+(j-1)*(lendata+1)]) ) + order = 1 + else + order = 0 + + return (order) +end diff --git a/pkg/utilities/nttools/lib/ftnexpr.x b/pkg/utilities/nttools/lib/ftnexpr.x new file mode 100644 index 00000000..a8472bdb --- /dev/null +++ b/pkg/utilities/nttools/lib/ftnexpr.x @@ -0,0 +1,127 @@ +include +define DOT '.' +define SQUOTE '\'' +define DQUOTE '"' +define BSLASH '\\' + +#* HISTORY * +#* B.Simon 04-Jan-93 Original +#* B.Simon 01-Dec-93 No longer removes backslashes + + +# FTNEXPR -- Convert a Fortran boolean expression to SPP + +procedure ftnexpr (oldexpr, newexpr, maxch) + +char oldexpr[ARB] # i: Fortran expression +char newexpr[ARB] # o: SPP expression +int maxch # i: Maximum length of SPP expression +#-- +char ch, term +int ic, jc, kc, iw +pointer sp, dotbuf + +string ftnlist ".eq. .and. .or. .gt. .ge. .lt. .le. .not. .ne." +string spplist " == && || > >= < <= ! !=" + +int gstrcpy(), word_match(), word_find() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (dotbuf, SZ_LINE, TY_CHAR) + + # Loop over each character in the old expression + # Characters between quote marks or dots are treated specially + # To indicate this, term is set to the leading character + + ic = 1 + jc = 1 + kc = 0 + term = EOS + + while (oldexpr[ic] != EOS) { + ch = oldexpr[ic] + + if (ch != term) { + if (term == EOS) { + if (ch == DOT) { + kc = 1 + term = ch + Memc[dotbuf] = ch + } else { + if (ch == SQUOTE || ch == DQUOTE) + term = ch + + newexpr[jc] = ch + jc = jc + 1 + } + + } else if (term == DOT) { + if (IS_ALPHA(ch)) { + if (kc < SZ_LINE) { + Memc[dotbuf+kc] = ch + kc = kc + 1 + } + } else { + Memc[dotbuf+kc] = ch + Memc[dotbuf+kc+1] = EOS + jc = jc + gstrcpy (Memc[dotbuf], newexpr[jc], + maxch-jc+1) + + kc = 0 + term = EOS + } + + } else { + newexpr[jc] = ch + jc = jc + 1 + + if (ch == BSLASH) { + ic = ic + 1 + newexpr[jc] = oldexpr[ic] + jc = jc + 1 + } + } + + } else { + term = EOS + + if (ch != DOT) { + newexpr[jc] = ch + jc = jc + 1 + + } else { + Memc[dotbuf+kc] = ch + Memc[dotbuf+kc+1] = EOS + call strlwr (Memc[dotbuf]) + + iw = word_match (Memc[dotbuf], ftnlist) + if (iw == 0) { + jc = jc + gstrcpy (Memc[dotbuf], newexpr[jc], + maxch-jc+1) + } else { + jc = jc + word_find (iw, spplist, newexpr[jc], + maxch-jc+1) + } + + kc = 0 + } + } + + ic = ic + 1 + } + + # If there is anything left in the dot buffer copy it unchanged + # to the output string + + newexpr[jc] = EOS + + if (kc > 0) { + Memc[dotbuf+kc] = EOS + call strcat (Memc[dotbuf], newexpr, maxch) + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/lib/gettabcol.x b/pkg/utilities/nttools/lib/gettabcol.x new file mode 100644 index 00000000..154aff4f --- /dev/null +++ b/pkg/utilities/nttools/lib/gettabcol.x @@ -0,0 +1,67 @@ +include + +# GETTABCOL -- Read in a table column of any data type +# +# This procedure produces an array of table column values and an array of +# null flags given an input table descriptor, column descriptor, and data +# type. If the data type is set to zero, the column data type is queried +# and returned to the calling program. The arrays are put in dynamic memory +# and pointers to these arrays are returned to the calling program, which must +# free the arrays when it is done with them. +# +# B.Simon 15-Dec-87 First Code + +procedure gettabcol (tp, cp, dtype, nary, aryptr, nulptr) + +pointer tp # i: Table descriptor +pointer cp # i: Column descriptor +int dtype # io: Data type of column (strings are -length) +int nary # o: Length of output arrays +pointer aryptr # o: Pointer to array of values +pointer nulptr # o: Pointer to array of null flags +#-- +int lendata, spptype +int tbpsta(), tbcigi() + +errchk malloc, tbpsta + +begin + # Allocate storage for null flags + + nary = tbpsta (tp, TBL_NROWS) + call malloc (nulptr, nary, TY_BOOL) + if (dtype == 0) + dtype = tbcigi (cp, TBL_COL_DATATYPE) + + # Break down data type into spp type and length + + if (dtype < 0) { + lendata = - dtype + spptype = TY_CHAR + } else { + lendata = 1 + spptype = dtype + } + + # Read in the column of table values + + switch (spptype) { + case TY_BOOL: + call malloc (aryptr, nary, TY_BOOL) + call tbcgtb (tp, cp, Memb[aryptr], Memb[nulptr], 1, nary) + case TY_CHAR: + call malloc (aryptr, nary*(lendata+1), TY_CHAR) + call tbcgtt (tp, cp, Memc[aryptr], Memb[nulptr], lendata, + 1, nary) + case TY_SHORT,TY_INT,TY_LONG: + call malloc (aryptr, nary, TY_INT) + call tbcgti (tp, cp, Memi[aryptr], Memb[nulptr], 1, nary) + case TY_REAL: + call malloc (aryptr, nary, TY_REAL) + call tbcgtr (tp, cp, Memr[aryptr], Memb[nulptr], 1, nary) + case TY_DOUBLE: + call malloc (aryptr, nary, TY_DOUBLE) + call tbcgtd (tp, cp, Memd[aryptr], Memb[nulptr], 1, nary) + } + +end diff --git a/pkg/utilities/nttools/lib/inquotes.x b/pkg/utilities/nttools/lib/inquotes.x new file mode 100644 index 00000000..2cc0d8ce --- /dev/null +++ b/pkg/utilities/nttools/lib/inquotes.x @@ -0,0 +1,121 @@ +include + +# inquotes -- Put quotes around string +# This procedure examines the input/output string for blanks, tabs and +# double quotes. If any of these is found, the string will be enclosed in +# double quotes (unless it already begins with "), and embedded quotes will +# be escaped with the '\' character. If the input string is null then it +# will be replaced with a pair of adjacent double quotes. If maxch is not +# large enough to include the extra characters, however, the string will not +# be modified. The input and output strings may be the same. +# +# If there are trailing blanks but no embedded blanks, tabs or quotes, +# then the input will be copied unmodified to the output. (6/17/92) +# +# The reason for enclosing a string in quotes is so that it may be read +# later using ctowrd, and the entire string will be taken as one "word". +# +# Phil Hodge, 21-Jul-1987 Subroutine created. +# Phil Hodge, 11-Aug-1987 Add outstr to calling sequence. +# Phil Hodge, 17-Jun-1992 Also check for tabs; ignore trailing whitespace. +# Phil Hodge, 13-Jan-1995 Include show_trailing argument in calling sequence. + +procedure inquotes (instr, outstr, maxch, show_trailing) + +char instr[ARB] # i: the string to be enclosed in quotes +char outstr[ARB] # o: copy of instr, possibly enclosed in quotes +int maxch # i: maximum length of string outstr +int show_trailing # i: YES means show trailing blanks +#-- +bool must_fix # true if str contains blanks and/or quotes +int non_blank_len # length of instr up to last non-blank char +int inlen # same as non_blank_len +int outlen # length of outstr on output +int numquotes # a count of the number of embedded quotes +int ip, op # counters for input & output locations +int strlen() + +begin + # Find the length of the string ... + if (show_trailing == YES) { + # ... including trailing blanks. + non_blank_len = strlen (instr) + } else { + # ... up to the last non-blank character. + non_blank_len = 0 # initial value + do ip = 1, maxch { + if (instr[ip] == EOS) + break + if (instr[ip] != BLANK) # else ignore blank + non_blank_len = ip + } + } + + # Replace a null or completely blank string with "". + if (instr[1] == EOS || non_blank_len < 1) { + if (maxch >= 2) + call strcpy ("\"\"", outstr, maxch) + else # can't fix it + call strcpy (instr, outstr, maxch) + return + } + + inlen = non_blank_len + numquotes = 0 # initial values + must_fix = false + + # Run through the input string, but only go as far as the last + # non-blank character so we don't include trailing blanks. + do ip = 1, non_blank_len { + if (instr[ip] == EOS) { + break + } else if (instr[ip] == BLANK) { + must_fix = true + } else if (instr[ip] == TAB) { + must_fix = true + } else if (instr[ip] == DQUOTE) { + if (ip == 1) { + call strcpy (instr, outstr, maxch) + return # begins with ", so don't "fix" it + } + if (instr[ip-1] != ESCAPE) { + must_fix = true + numquotes = numquotes + 1 + } + } + } + + outlen = inlen + numquotes + 2 + if (outlen > maxch || !must_fix) { + call strcpy (instr, outstr, maxch) + return # can't fix it or don't need to + } + + # Work from the end toward the beginning in case instr = outstr. + outstr[outlen+1] = EOS + outstr[outlen] = DQUOTE + op = outlen - 1 + + if (numquotes > 0) { + # There are quotes within the string. + do ip = inlen, 1, -1 { + outstr[op] = instr[ip] + if (instr[ip] == DQUOTE) { + if (instr[ip-1] != ESCAPE) { + op = op - 1 + outstr[op] = ESCAPE + } + } + op = op - 1 + } + } else { + # No embedded quotes. + do ip = inlen, 1, -1 { + outstr[op] = instr[ip] + op = op - 1 + } + } + outstr[1] = DQUOTE + if (op != 1) + call error (1, "miscount in inquotes") +end diff --git a/pkg/utilities/nttools/lib/invert.x b/pkg/utilities/nttools/lib/invert.x new file mode 100644 index 00000000..f8a36675 --- /dev/null +++ b/pkg/utilities/nttools/lib/invert.x @@ -0,0 +1,55 @@ + +include + +# INVERT -- Create the complement (inverse) of an array of column pointers +# +# B.Simon 20-Oct-87 First Code + +procedure invert (tp, numptr, colptr) + +pointer tp # i: Table descriptor +int numptr # io: Number of column pointers +pointer colptr[ARB] # io: Array of column pointers + +bool match +int numcol, icol, iptr, jptr +pointer newptr, cp + +int tbpsta(), tbcnum() + +begin + # Create a temporary array to hold the pointers + + numcol = tbpsta (tp, TBL_NCOLS) + call malloc (newptr, numcol, TY_INT) + + jptr = 0 + do icol = 1, numcol { + + # Get each pointer in the table and + # see if it is in the original array + + cp = tbcnum (tp, icol) + match = false + do iptr = 1, numptr { + if (cp == colptr[iptr]) { + match = true + break + } + } + + # If not, add it to the temporary array + + if (! match) { + Memi[newptr+jptr] = cp + jptr = jptr + 1 + } + } + +# Copy the temporary array to the output array + + numptr = jptr + call amovi (Memi[newptr], colptr, numptr) + call mfree (newptr, TY_INT) + +end diff --git a/pkg/utilities/nttools/lib/mjd.x b/pkg/utilities/nttools/lib/mjd.x new file mode 100644 index 00000000..601cf546 --- /dev/null +++ b/pkg/utilities/nttools/lib/mjd.x @@ -0,0 +1,94 @@ +include +include "reloperr.h" + +define TFIELDS 7 +define REQFIELD 3 + +# MJD -- Compute the modified julian date of a time expressed as a string +# +# Dates are of the form YYYYMMDD:HHMMSSCC (fields after the colon are optional). +# If an optional field is not present, its value is considered to be zero. +# Dates must be between 1 Jan 1858 and 31 Dec 2099 +# +# B.Simon 7-Oct-87 First Code +# Phil Hodge 20-Feb-91 Move the data statements. + +double procedure mjd (date) + +char date[ARB] # i: String in the form YYYYMMDD:HHMMSSCC +#-- +int jd, datelen, it, ic +int time[TFIELDS], tpos[2,TFIELDS], tlim[2,TFIELDS] +pointer sp, errtxt +double df + +int strlen() + +string badfmt "Date has incorrect format (%s)" + +data tpos / 1, 4, 5, 6, 7, 8, 10, 11, 12, 13, 14, 15, 16, 17 / +data tlim / 1858, 2099, 1, 12, 1, 31, 0, 23, 0, 59, 0, 59, 0, 99 / + +begin + # Allocate dynamic memory for error string + + call smark (sp) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + datelen = strlen (date) + call aclri (time, TFIELDS) + + # Convert the date string into integer fields + + do it = 1, TFIELDS { + + # Check for absence of optional fields + + if (tpos[1,it] > datelen) { + if (it > REQFIELD) + break + else { + call sprintf (Memc[errtxt], SZ_LINE, badfmt) + call pargstr (date) + call error (SYNTAX, Memc[errtxt]) + } + } + + # Convert a field in the date string to an integer + + do ic = tpos[1,it], tpos[2,it] { + if (IS_DIGIT(date[ic])) + time[it] = 10 * time[it] + TO_INTEG(date[ic]) + else { + call sprintf (Memc[errtxt], SZ_LINE, badfmt) + call pargstr (date) + call error (SYNTAX, Memc[errtxt]) + } + } + + # Do bounds checking on the field + # Some errors can slip thru, e.g., Feb 30 + + if ((time[it] < tlim[1,it]) || (time[it] > tlim[2,it])) { + call sprintf (Memc[errtxt], SZ_LINE, badfmt) + call pargstr (date) + call error (SYNTAX, Memc[errtxt]) + } + } + + # Compute integer part of modified julian date + # From Van Flandern & Pulkkinen ApJ Sup 41:391-411 Nov 79 + + jd = 367 * time[1] - 7 * (time[1] + (time[2] + 9) / 12) / 4 - + 3 * ((time[1] + (time[2] - 9) / 7) / 100 + 1) / 4 + + 275 * time[2] / 9 + time[3] - 678971 + + # Compute fractional part of modified julian date + # N.B. julian date begins at noon, modified julian date at midnight + + df = double (time[7] + 100 * (time[6] + 60 * + (time[5] + 60 * time[4]))) / 8640000.0 + + call sfree (sp) + return (jd + df) +end diff --git a/pkg/utilities/nttools/lib/mkpkg b/pkg/utilities/nttools/lib/mkpkg new file mode 100644 index 00000000..3644f8e3 --- /dev/null +++ b/pkg/utilities/nttools/lib/mkpkg @@ -0,0 +1,33 @@ +# Update the library application code in the ttools package library +# Author: B.Simon, 21-Dec-87 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + allcols.x + allrows.x + ftnexpr.x + gettabcol.x + inquotes.x + invert.x + mjd.x reloperr.h + newcolnam.x reloperr.h + reorder.x + select.x reloperr.h + tabvar.x "../tabvar.com" + tbfile.x + tuopen.x + tbleval.x \ + reloperr.h tblterm.com + tblsearch.x \ + reloperr.h tblterm.com + tblsort.x + tblterm.x \ + reloperr.h tblterm.com + tctexp.x reloperr.h + tldtype.x + unique.x + ; diff --git a/pkg/utilities/nttools/lib/movenulls.x b/pkg/utilities/nttools/lib/movenulls.x new file mode 100644 index 00000000..5e961d20 --- /dev/null +++ b/pkg/utilities/nttools/lib/movenulls.x @@ -0,0 +1,35 @@ +# MOVENULLS -- Move all null elements to the end of the index array +# +# This procedure rearranges an array of row indices so that all rows with +# nulls in a particular column are moved to the end of the index array. +# The position of the nulls in the column is indicated by an array of null +# flags, whose length might be greater than the length of the array of +# indices, i.e., only a subset of the rows in a table might be in the index +# array. +# +# B.Simon 15-Dec-87 First Code + +int procedure movenulls (nindex, nulflg, index) + +int nindex # i: Number of indices +bool nulflg[ARB] # i: Array of null flags +int index[ARB] # io: Array of row indices +#-- +int nelem, idx, jdx + +begin + nelem = nindex + + do idx = nindex, 1, -1 { + jdx = index[idx] + if (nulflg[jdx]) { + if (nelem != idx) { + index[idx] = index[nelem] + index[nelem] = jdx + } + nelem = nelem - 1 + } + } + + return (nelem) +end diff --git a/pkg/utilities/nttools/lib/msort.x b/pkg/utilities/nttools/lib/msort.x new file mode 100644 index 00000000..2731351f --- /dev/null +++ b/pkg/utilities/nttools/lib/msort.x @@ -0,0 +1,113 @@ +include "reloperr.h" + +# MSORT -- General merge sort for arbitrary objects. X is an integer array +# indexing the array to be sorted. The user supplied COMPARE function is used +# to compare objects indexed by X: +# +# -1,0,1 = compare (x1, x2) +# +# where the value returned by COMPARE has the following significance: +# +# -1 obj[x1] < obj[x2] +# 0 obj[x1] == obj[x2] +# 1 obj[x1] > obj[x2] +# +# MSORT reorders the elements of the X array, which must be of type integer. +# +# B.Simon 28-Sept-87 First Code + +procedure msort (x, nx, nelem, compare) + +int x[ARB] # array to be sorted +int nx # length of array x (Must be >= 2 * nelem) +int nelem # number of elements to be sorted +extern compare() # function to be called to compare elements +#-- +bool up +int ielem, jelem, kelem, melem +int runlen, ilen, jlen + +int compare() + +begin + if (2 * nelem > nx) + call error (BOUNDS, "Index array too small") + + # Merging two sorted runs creates a new sorted run twice the length + # of the original run. Continue this process until the sorted run + # length is equal to the array length. + + up = false + for (runlen = 1; runlen < nelem; runlen = 2 * runlen) { + + # The runs are stored in one of two halves of the x array. + # Set the array pointers according to the half the runs are + # located in now. + + if (! up) { + ielem = 1 + jelem = runlen + 1 + kelem = nx - nelem + 1 + melem = nelem + } else { + ielem = nx - nelem + 1 + jelem = runlen + ielem + kelem = 1 + melem = nx + } + + # Loop over each pair of runs in the array + + while (ielem <= melem) { + ilen = min (runlen, melem-ielem+1) + jlen = min (runlen, melem-jelem+1) + + # Merge the pair of runs into the other half of the x array + + while (ilen > 0 && jlen > 0) { + if (compare (x[ielem], x[jelem]) <= 0) { + x[kelem] = x[ielem] + ielem = ielem + 1 + kelem = kelem + 1 + ilen = ilen - 1 + } else { + x[kelem] = x[jelem] + jelem = jelem + 1 + kelem = kelem + 1 + jlen = jlen - 1 + } + } + + # Copy the remaining elements from i when j is exhausted + + while (ilen > 0) { + x[kelem] = x[ielem] + ielem = ielem + 1 + kelem = kelem + 1 + ilen = ilen - 1 + } + + # Copy the remaining elements from j when i is exhausted + + while (jlen > 0) { + x[kelem] = x[jelem] + jelem = jelem + 1 + kelem = kelem + 1 + jlen = jlen - 1 + } + + # Set array pointers to next set of runs + + ielem = ielem + runlen + jelem = jelem + runlen + } + up = ! up + } + + # If result is in the upper end of x array, move it to the lower + # end + + if (up) + call amovi (x[nx-nelem+1], x[1], nelem) + + end diff --git a/pkg/utilities/nttools/lib/newcolnam.x b/pkg/utilities/nttools/lib/newcolnam.x new file mode 100644 index 00000000..4179383d --- /dev/null +++ b/pkg/utilities/nttools/lib/newcolnam.x @@ -0,0 +1,97 @@ +include +include +include "reloperr.h" + +# NEWCOLNAM -- Create a new, unique column name +# +# This procedure receives as input an array of column pointers from two or +# more tables and an index into that array. If the name of the column pointed +# to by that index is unique, it is output as the new name. If it is not +# unique, a suffix of the form "_i" is appended to the name, where i is +# a digit which (hopefully) makes the name unique. +# +# B.Simon 3-Nov-87 first code +# B.Simon 4-Sep-90 Replaced call to strncmp with streq + +procedure newcolnam (numcol, colptr, colidx, newnam, maxch) + +int numcol # i: Number of column pointers +pointer colptr[ARB] # i: Array of column pointers +int colidx # i: Index to column to be renamed +char newnam[ARB] # o: New column name +int maxch # i: Maximum characters in new name +#-- +int olen, nmatch, nbefore, icol +pointer sp, oldnam, colnam, errtxt + +string notuniq "Cannot create a unique column name (%s)" + +bool streq() +int strlen() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (oldnam, SZ_COLNAME, TY_CHAR) + call salloc (colnam, SZ_COLNAME, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Read column name pointed to by index + + call tbcigt (colptr[colidx], TBL_COL_NAME, Memc[oldnam], SZ_COLNAME) + call strupr (Memc[oldnam]) + + # See if the name is unique, and if not, how many columns with + # the same name precede this one + + nmatch = 0 + nbefore = 0 + do icol = 1, numcol { + call tbcigt (colptr[icol], TBL_COL_NAME, Memc[colnam], SZ_COLNAME) + call strupr (Memc[colnam]) + + if (streq (Memc[colnam], Memc[oldnam])) { + nmatch = nmatch + 1 + if (icol <= colidx) + nbefore = nbefore + 1 + } + } + + # If the name is not unique, add a suffix of the form "_i" + + if (nmatch > 1) { + + # Check for ridiculous values of maxch + + olen = min (maxch-2, strlen(Memc[oldnam])) + if (olen < 1) { + call sprintf (Memc[errtxt], SZ_LINE, notuniq) + call pargstr (Memc[oldnam]) + call error (SYNTAX, Memc[errtxt]) + } + + # Add the suffix + + Memc[oldnam+olen] = '_' + Memc[oldnam+olen+1] = TO_DIGIT (nbefore) + Memc[oldnam+olen+2] = EOS + + # Make sure it is unique + + do icol = 1, numcol { + call tbcigt (colptr[icol], TBL_COL_NAME, Memc[colnam], + SZ_COLNAME) + if (streq (Memc[oldnam], Memc[colnam])) { + call sprintf (Memc[errtxt], SZ_LINE, notuniq) + call pargstr (Memc[oldnam]) + call error (SYNTAX, Memc[errtxt]) + } + } + } + + # Copy to the output string + + call strcpy (Memc[oldnam], newnam, maxch) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/lib/reloperr.h b/pkg/utilities/nttools/lib/reloperr.h new file mode 100644 index 00000000..6dff85c7 --- /dev/null +++ b/pkg/utilities/nttools/lib/reloperr.h @@ -0,0 +1,3 @@ +define SYNTAX 1 +define BOUNDS 2 +define PUTNULL 11 diff --git a/pkg/utilities/nttools/lib/reorder.x b/pkg/utilities/nttools/lib/reorder.x new file mode 100644 index 00000000..cacd98e2 --- /dev/null +++ b/pkg/utilities/nttools/lib/reorder.x @@ -0,0 +1,60 @@ +include + +# REORDER -- Reorder table rows according to an index array +# +# This procedure rearranges the rows of a table according to the contents +# of an index array. The index array is produced by one of the two table +# sort routines, tsort1 or tsortm. The algorithm used is taken from Knuth's +# Sorting and Searching p.595. +# +# B.Simon 17-Sept-87 First Code +# B.Simon 15-Jul-88 Rewritten +# Phil Hodge 12-Sep-88 Don't include tbtables.h + +procedure reorder (tp, nindex, index) + +pointer tp # i: Table descriptor +int nindex # i: Number of indices +int index[ARB] # io: Array of row indices +#-- +int idx, jdx, kdx, ndx +int tbpsta() + +errchk tbrcpy + +begin + # Use the row after the end of the table for temporary storage + + ndx = tbpsta (tp, TBL_NROWS) + 1 + + # Loop over all rows of the table, moving them into their proper + # order + + do idx = 1, nindex { + + # The index array forms one or more cycles. Move the first + # row in the cycle to the temporary location. Repeatedly + # move the remaining rows in the cycle until the final + # location of the first row is found. Move the first row + # from its temporary location to its final location. Update + # the index array to indicate which rows have been moved. + + if (index[idx] != idx) { + call tbrcpy (tp, tp, idx, ndx) + jdx = idx + while (index[jdx] != idx) { + kdx = index[jdx] + call tbrcpy (tp, tp, kdx, jdx) + index[jdx] = jdx + jdx = kdx + } + call tbrcpy (tp, tp, ndx, jdx) + index[jdx] = jdx + } + + } + + # Remove the temporary row + + call tbrdel (tp, ndx, ndx) +end diff --git a/pkg/utilities/nttools/lib/select.x b/pkg/utilities/nttools/lib/select.x new file mode 100644 index 00000000..02cc73f8 --- /dev/null +++ b/pkg/utilities/nttools/lib/select.x @@ -0,0 +1,99 @@ +include "reloperr.h" + +# SELECT -- Select table rows according to expression +# +# This procedure evaluates a boolean expession for selected rows in a table. +# If the expression is true and does not involve null elements, the index +# of that row is kept in the index array. +# +# B.Simon 7-Oct-87 First Code +# B.Simon 16-Dec-87 Changed to handle table subsets +# B.Simon 06-Jan-93 Changed to use ftnexpr + +procedure select (tp, expr, nindex, index) + +pointer tp # i: Table descriptor +char expr[ARB] # i: Algebraic expression used in selection +int nindex # io: Number of rows selected +int index[ARB] # io: Indices of selected rows +#-- +char ch +pointer sp, oldexp, newexp, ic, aryptr, nulptr +int fd, sd, jc, dtype, nary, iary + +int open(), stropen(), stridx() + +errchk open, stropen, tbl_eval + +string badtype "Expression is not boolean" + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (oldexp, SZ_COMMAND, TY_CHAR) + call salloc (newexp, SZ_COMMAND, TY_CHAR) + + # Check to see if the expression is a file name + + if (expr[1] == '@') { + + # Copy the file into a string + + fd = open (expr[2], READ_ONLY, TEXT_FILE) + sd = stropen (Memc[oldexp], SZ_COMMAND, WRITE_ONLY) + call fcopyo (fd, sd) + call close (fd) + call strclose (sd) + + # Replace the newlines with blanks + + ic = oldexp + ch = '\n' + repeat { + jc = stridx (ch, Memc[ic]) + if (jc == 0) + break + ic = ic + jc + Memc[ic-1] = ' ' + } + + # Convert Fortran relational operators to SPP + + call ftnexpr (Memc[oldexp], Memc[newexp], SZ_COMMAND) + + } else { + + # Convert Fortran relational operators to SPP + + call ftnexpr (expr, Memc[newexp], SZ_COMMAND) + } + + # Evaluate the expression + + dtype = TY_BOOL + call tbl_eval (tp, nindex, index, Memc[newexp], dtype, aryptr, nulptr) + + # Check to see if result is boolean + + if (dtype != TY_BOOL) { + call mfree (aryptr, dtype) + call mfree (nulptr, TY_BOOL) + call error (SYNTAX, badtype) + } + + # Put indices of true, non-null rows in index array + + nary = nindex + nindex = 0 + do iary = 1, nary + + if (Memb[aryptr+iary-1] && ! Memb[nulptr+iary-1]) { + nindex = nindex + 1 + index[nindex] = index[iary] + } + + call mfree (aryptr, dtype) + call mfree (nulptr, TY_BOOL) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/lib/tabvar.x b/pkg/utilities/nttools/lib/tabvar.x new file mode 100644 index 00000000..339f2d95 --- /dev/null +++ b/pkg/utilities/nttools/lib/tabvar.x @@ -0,0 +1,118 @@ +include + +# TABVAR -- Retrieve a table column given its name +# +# B.Simon 03-May-91 Original +# B.Simon 23-Jun-97 Peicewise evaluation of column + +procedure tabvar (stack, colname) + +pointer stack # u: Expression stack pointer +char colname[ARB] # i: Column name +#-- +include "../tabvar.com" + +int i, coltype, nrows +pointer sp, nullbuf, buffer, errmsg, cp + +string badcolnam "Column name not found (%s)" + +bool streq() +int tbcigi() +pointer stk_alloc() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Get column pointer from name + + call tbcfnd (tabptr, colname, cp, 1) + if (cp == NULL) { + if (streq (colname, "rownum")) { + call rowvar (stack) + return + } else { + call sprintf (Memc[errmsg], SZ_LINE, badcolnam) + call pargstr (colname) + call error (1, Memc[errmsg]) + } + } + + # Get column type + + coltype = tbcigi (cp, TBL_COL_DATATYPE) + if (coltype == TY_BOOL || coltype == TY_SHORT || coltype == TY_LONG) { + coltype = TY_INT + } else if (coltype < 0) { + coltype = TY_DOUBLE + } + + # Allocate a buffer on the expression evaluator stack + + nrows = (lastrow - firstrow) + 1 + call malloc (nullbuf, nrows, TY_BOOL) + buffer = stk_alloc (stack, nrows, coltype) + + # Copy the table column into the buffer + # Substitute the user supplied vales for nulls + + switch (coltype) { + case TY_SHORT, TY_INT, TY_LONG: + call tbcgti (tabptr, cp, Memi[buffer], Memb[nullbuf], + firstrow, lastrow) + do i = 0, nrows-1 { + if (Memb[nullbuf+i]) + Memi[buffer+i] = nullval + } + + case TY_REAL: + call tbcgtr (tabptr, cp, Memr[buffer], Memb[nullbuf], + firstrow, lastrow) + do i = 0, nrows-1 { + if (Memb[nullbuf+i]) + Memr[buffer+i] = nullval + } + case TY_DOUBLE: + call tbcgtd (tabptr, cp, Memd[buffer], Memb[nullbuf], + firstrow, lastrow) + do i = 0, nrows-1 { + if (Memb[nullbuf+i]) + Memd[buffer+i] = nullval + } + } + + # Update the null array + call stk_ornull (stack, Memb[nullbuf], nrows) + + call mfree (nullbuf, TY_BOOL) + call sfree (sp) + +end + +# ROWVAR -- Handle the variable "rownum" + +procedure rowvar (stack) + +pointer stack # u: Expression stack pointer +#-- +include "../tabvar.com" + +int irow, nrows +pointer buffer + +pointer stk_alloc() + +begin + # Allocate a buffer on the expression evaluator stack + + nrows = (lastrow - firstrow) + 1 + buffer = stk_alloc (stack, nrows, TY_INT) + + # Fill the buffer with the row number + do irow = 0, nrows-1 + Memi[buffer+irow] = firstrow + irow +end + diff --git a/pkg/utilities/nttools/lib/tbfile.x b/pkg/utilities/nttools/lib/tbfile.x new file mode 100644 index 00000000..d11e1720 --- /dev/null +++ b/pkg/utilities/nttools/lib/tbfile.x @@ -0,0 +1,85 @@ +include # for IS_ALNUM + +# tbfile -- get table and file name +# This routine takes a table name as specified by a user and returns +# the full table name, the full file name, and the filename extension +# (including the dot; e.g. ".tab"). The filename extension may be the +# null string if the file is a text table. The file name will be a +# subset of the table name, as the table name may include a bracketed +# expression giving EXTNAME or HDU number or table name in CDF file. +# +# Phil Hodge, 27-Jun-1995 Subroutine created. +# Phil Hodge, 29-Sep-1997 No longer necessary to enclose extname expression +# in brackets, as the brackets are now included. +# Phil hodge, 16-Apr-1999 Remove ttype from calling sequence of tbparse. + +procedure tbfile (input, tabname, filename, extn, maxch) + +char input[ARB] # i: input table name +char tabname[maxch] # o: full table name +char filename[maxch] # o: name of file containing table +char extn[maxch] # o: filename extension, including '.' +int maxch # i: size of strings +#-- +pointer sp +pointer fname # full file name +pointer brackets # for CDF or HDU name or number, and/or selectors +int hdu # returned by tbparse and ignored +int dotloc # location of last '.' in file name +int i +int strlen(), access() +int tbparse() +bool strne() +errchk tbparse, tbtext + +begin + call smark (sp) + call salloc (fname, SZ_LINE, TY_CHAR) + call salloc (brackets, SZ_LINE, TY_CHAR) + + # Separate filename from any bracketed expression (such as + # EXTNAME or HDU number) that may be present. + if (tbparse (input, Memc[fname], Memc[brackets], SZ_LINE, hdu) < 1) { + tabname[1] = EOS + filename[1] = EOS + extn[1] = EOS + call sfree (sp) + return + } + + # Append default extension (if appropriate) to get full file name. + # A text table need not have an extension, so first check whether + # a file of the given name exists. If not, then append extension. + if (access (Memc[fname], 0, 0) == NO && + strne (input, "STDIN") && strne (input, "STDOUT")) + call tbtext (Memc[fname], Memc[fname], SZ_LINE) + + # At this point we have the full file name; copy it to output. + call strcpy (Memc[fname], filename, maxch) + + # Append bracketed expression (if present) to get full table name, + # and copy it to output. + call strcpy (Memc[fname], tabname, maxch) + if (Memc[brackets] != EOS) + call strcat (Memc[brackets], tabname, maxch) + + # Search for a filename extension. Look for a dot that is not + # followed by any special character. + dotloc = 0 # initial value + do i = strlen (Memc[fname]), 1, -1 { + if (Memc[fname+i-1] == '.') { # found it + dotloc = i + break + } + if (!IS_ALNUM(Memc[fname+i-1])) # stop at first special char + break + } + + # If the file name includes an extension, copy it to output. + if (dotloc > 0) + call strcpy (Memc[fname+dotloc-1], extn, maxch) + else + extn[1] = EOS + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/lib/tbleval.x b/pkg/utilities/nttools/lib/tbleval.x new file mode 100644 index 00000000..c9382699 --- /dev/null +++ b/pkg/utilities/nttools/lib/tbleval.x @@ -0,0 +1,159 @@ +include +include +include +include +include "reloperr.h" + +# TBL_EVAL -- Evaluate an arbitrary expression over table columns +# +# This procedure receives as input a table descriptor, an index array, and +# a character string containing an algebraic expression. The terms in the +# expression are column names. The expression is evaluated for each row in +# the index array using the values from the indicated columns and the results +# stored in the output array (aryptr). The array pointed to by nulptr +# contains null flags. A null flag is set to true if any of the table elements +# in the expression is null or an arithmetic error ocurs during the +# evaluation of the expression. Otherwise the null flag is set to false. +# The type of the output array is determined by the type of the expression +# unless all the elements are null, in which case the type input by the +# calling routine is used. The two arrays pointed to by aryptr and nulptr +# must be deallocated by the calling routine. +# +# B.Simon 29-Sept-87 First Code +# B.Simon 16-Dec-87 Changed to handle table subsets +# B.Simon 13-Apr-88 tbl_term, tbl_func moved to separate file + +procedure tbl_eval (tp, nindex, index, expr, dtype, aryptr, nulptr) + +pointer tp # i: Table descriptor +int nindex # i: Number of elements in index array +int index[ARB] # i: Array of row indices +char expr[ARB] # i: Expression to be evaluated +int dtype # io: Type of output array +pointer aryptr # o: Array of output values +pointer nulptr # o: Array of null flags +#-- +include "tblterm.com" + +int iary, status, junk +int old_handler, tbl_term_adr, tbl_func_adr +pointer op + +string badtype "Character expressions not allowed" + +int locpr(), errcode() +pointer evexpr() + +extern tbl_handler(), tbl_term(), tbl_func() + +begin + # Initialize output variables + + aryptr = NULL + call malloc (nulptr, nindex, TY_BOOL) + + # Set up error handler to catch arithmetic errors + + call xwhen (X_ARITH, locpr(tbl_handler), old_handler) + + table = tp + nterm = 0 + constant = true + + tbl_term_adr = locpr (tbl_term) + tbl_func_adr = locpr (tbl_func) + + # Loop over all rows of the table + + do iary = 1, nindex { + + irow = index[iary] + iterm = 0 + + # Execution will resume here when an arithmetic error occurs + + call zsvjmp (jumpbuf, status) + + if (status != OK) { + Memb[nulptr+iary-1] = true + + # Special case to speed up the evaluation of constant expressions + + } else if (constant && (iary != 1)) { + Memb[nulptr+iary-1] = false + switch (dtype) { + case TY_BOOL: + Memb[aryptr+iary-1] = Memb[aryptr] + case TY_INT: + Memi[aryptr+iary-1] = Memi[aryptr] + case TY_REAL: + Memr[aryptr+iary-1] = Memr[aryptr] + } + + # Evaluate the expression using the values in the current row + + } else { + iferr { + op = evexpr (expr, tbl_term_adr, tbl_func_adr) + } then { + + # Catch the error sent when a table element is null + + if (errcode() == PUTNULL) + Memb[nulptr+iary-1] = true + else { + call mfree (nulptr, TY_BOOL) + call xwhen (X_ARITH, old_handler, junk) + call erract (EA_ERROR) + } + + # Usual case + + } else { + + Memb[nulptr+iary-1] = false + + # Determine array type from type of expression + + if (aryptr == NULL) { + if (O_TYPE(op) == TY_CHAR) { + call mfree (nulptr, TY_BOOL) + call xwhen (X_ARITH, old_handler, junk) + call error (SYNTAX, badtype) + } + dtype = O_TYPE(op) + call calloc (aryptr, nindex, dtype) + } + + # Assign the result of the expression to the output + # array + + switch (dtype) { + case TY_BOOL: + Memb[aryptr+iary-1] = O_VALB(op) + case TY_INT: + Memi[aryptr+iary-1] = O_VALI(op) + case TY_REAL: + Memr[aryptr+iary-1] = O_VALR(op) + } + + call mfree (op, TY_STRUCT) # Bug fix (BPS 04.20.93) + } + } + } + + # Allocate array when all results are null + + if (aryptr == NULL) { + if (dtype == TY_CHAR) { + call mfree (nulptr, TY_BOOL) + call xwhen (X_ARITH, old_handler, junk) + call error (SYNTAX, badtype) + } + call calloc (aryptr, nindex, dtype) + } + # Restore old error handler + + call xwhen (X_ARITH, old_handler, junk) + +end diff --git a/pkg/utilities/nttools/lib/tbljoin.x b/pkg/utilities/nttools/lib/tbljoin.x new file mode 100644 index 00000000..c2a26fd6 --- /dev/null +++ b/pkg/utilities/nttools/lib/tbljoin.x @@ -0,0 +1,168 @@ +include +define MAXPRI 7 + +# TBL_JOIN -- Relational join of two tables +# +# This procedure peforms a relational join by sorting the two tables on +# the column to be joined and then merging the tables on the basis of the +# common column. An input tolerance is used to control the test for equality +# in the merge. The variables which describe the two tables are the table +# descriptors (tp1 & tp2), column descriptors (cp1 & cp2), row index arrays +# (index1 & index2), and index array lengths (nindex1 & nindex2). The merged +# output table is described by two index arrays which contain the row indices +# from the respective input tables (index3 & index4) and the index array +# lengths (nindex3 & nindex4). On input these lengths are the declared length +# of the output index arrays, on output, they are the number of rows in +# the merged output table. The total number of merged rows is output as +# njoin. The output index arrays may not be large enough to hold the merged +# table indices. In this case, the output index arrays will be filled as much +# as possible. So if njoin is greater than nindex3 or nindex4, an error has +# occured, but this error can be recovered from by reallocating the output +# index arrays so that the can hold njoin elements and calling this procedure +# again. +# +# B.Simon 03-Nov-87 First Code +# B.Simon 16-Dec-87 Changed to handle table subsets +# B.Simon 06-Feb-90 Changed to use tbtsrt + +procedure tbl_join (tol, casesens, tp1, tp2, cp1, cp2, nindex1, nindex2, + index1, index2, nindex3, nindex4, index3, index4, njoin) + +double tol # i: Tolerance used in testing for equality +bool casesens # i: Join is case sensitive +pointer tp1 # i: Table descriptor of first table +pointer tp2 # i: Table descriptor of second table +pointer cp1 # i: Column descriptor of merged column in first table +pointer cp2 # i: Column descriptor of merged column in second table +int nindex1 # i: Number of indices in first input array +int nindex2 # i: Number of indices in second input array +int index1 # i: Array of row indices for first input table +int index2 # i: Array of row indices for second input table +int nindex3 # io: Number of indices in first output array +int nindex4 # io: Number of indices in second output array +int index3 # o: Array of row indices for first output table +int index4 # o: Array of row indices for second output table +int njoin # o: Number of joined rows +#-- +bool fold +int dtype[2], spptype[2], lendata[2], colpri[2], nary[2], nidx[2] +int itab, iary, nmax + +pointer nulptr, temptr, curptr +pointer tp[2], cp[2], idxptr[2], aryptr[2] + +int priority[MAXPRI] +data priority / TY_DOUBLE, TY_REAL, TY_LONG, TY_INT, TY_SHORT, + TY_CHAR, TY_BOOL / +double mjd() +int tbcigi() + +begin + # Move input variables into arrays + + fold = ! casesens + + tp[1] = tp1 + tp[2] = tp2 + + cp[1] = cp1 + cp[2] = cp2 + + nmax = min (nindex3, nindex4) + + nidx[1] = nindex1 + nidx[2] = nindex2 + + call malloc (idxptr[1], nindex1, TY_INT) + call amovi (index1, Memi[idxptr[1]], nindex1) + + call malloc (idxptr[2], nindex2, TY_INT) + call amovi (index2, Memi[idxptr[2]], nindex2) + + # Determine the data type of the merged column + + do itab = 1, 2 { + + dtype[itab] = tbcigi (cp[itab], TBL_COL_DATATYPE) + + if (dtype[itab] < 0) { + lendata[itab] = - dtype[itab] + spptype[itab] = TY_CHAR + } else { + lendata[itab] = 1 + spptype[itab] = dtype[itab] + } + + for (colpri[itab] = 1; + spptype[itab] != priority[colpri[itab]]; + colpri[itab] = colpri[itab] + 1 + ) ; + + } + + if (colpri[1] < colpri[2]) { + spptype[2] = spptype[1] + lendata[2] = lendata[1] + } else if (colpri[2] < colpri[1]) { + spptype[1] = spptype[2] + lendata[1] = lendata[2] + } + + # Read common columns into arrays and sort + + do itab = 1, 2 { + + # Sort the index array on the common column + + call tbtsrt (tp[itab], 1, cp[itab], fold, + nidx[itab], Memi[idxptr[itab]]) + + # Read in the common column + + if (spptype[itab] == TY_CHAR) + dtype[itab] = - lendata[itab] + else + dtype[itab] = spptype[itab] + + call gettabcol (tp[itab], cp[itab], dtype[itab], + nary[itab], aryptr[itab], nulptr) + + # If the tolerance of a string column is non-zero, + # interpret the column as a date + + if (dtype[itab] < 0 && tol > 0.0) { + + call malloc (temptr, nary[itab], TY_DOUBLE) + curptr = aryptr[itab] + do iary = 1, nary[itab] { + if (Memb[nulptr+iary-1]) + Memd[temptr+iary-1] = INDEFD + else + Memd[temptr+iary-1] = mjd (Memc[curptr]) + curptr = curptr + lendata[itab] + 1 + } + call mfree (aryptr[itab], TY_CHAR) + dtype[itab] = TY_DOUBLE + spptype[itab] = TY_DOUBLE + lendata[itab] = 1 + aryptr[itab] = temptr + } + } + + # Merge the two tables + + call tbl_merge (tol, dtype, nary, aryptr, nidx, idxptr, + nmax, njoin, index3, index4) + + nindex3 = min (nmax, njoin) + nindex4 = min (nmax, njoin) + + # Free dynamic memory + + call mfree (nulptr, TY_BOOL) + do itab = 1, 2 { + call mfree (idxptr[itab], TY_INT) + call mfree (aryptr[itab], spptype[itab]) + } + +end diff --git a/pkg/utilities/nttools/lib/tblmerge.x b/pkg/utilities/nttools/lib/tblmerge.x new file mode 100644 index 00000000..ead8cbe6 --- /dev/null +++ b/pkg/utilities/nttools/lib/tblmerge.x @@ -0,0 +1,162 @@ +include "reloperr.h" + +# TBL_MERGE -- Merge two tables on the basis of a common column +# +# This procedure creates an array of row indices from two tables where the +# row indices point to a pair of rows where the values stored in the two +# columns are equal within an input tolerance. The column values are stored in +# the two arrays pointed to by aryptr. The two columns must already be sorted +# in ascending order with the row indices of the two columns stored in the +# arrays pointed to by idxptr. This procedure keeps on going even when an +# output array overflow condition is detected so that the caller knows how +# large the output array must be. +# +# B.Simon 1-Nov-87 First code +# B.Simon 16-Dec-87 Changed to handle table subsets + +procedure tbl_merge (tol, dtype, nary, aryptr, nidx, idxptr, nmax, + nmerge, index1, index2) + +double tol # i: Tolerance used in test for equality +int dtype[2] # i: Data types of columns +int nary[2] # i: Size of arrays containing columns +pointer aryptr[2] # i: Pointers to column arrays +int nidx[2] # i: Size of arrays containing row indices +pointer idxptr[2] # i: Pointers to index arrays +int nmax # i: Max size of arrays containing merged row indices +int nmerge # o: Number of merged row indices +int index1[ARB] # o: Array of merged row indices for first table +int index2[ARB] # o: Array of merged row indices for second table +#-- +double dbl_tol +int itab, int_tol, idx, jdx, kdx, order, lendata[2], spptype[2] +pointer ptr1, ptr2 +real real_tol + +bool strlt(), strgt() + +string badtype "Data types of the two columns to be merged must be equal" +string badtol "Tolerance for boolean or character columns must be zero" + +begin + # Get data type and length from dtype + + do itab = 1, 2 { + if (dtype[itab] < 0) { + lendata[itab] = 1 - dtype[itab] + spptype[itab] = TY_CHAR + } else { + lendata[itab] = 1 + spptype[itab] = dtype[itab] + } + } + + if (spptype[1] != spptype[2]) + call error (SYNTAX, badtype) + + # Convert tolerance to the same type as the data + + switch (spptype[1]) { + case TY_BOOL, TY_CHAR: + if (tol > 0.0) + call error (SYNTAX, badtol) + case TY_SHORT, TY_INT, TY_LONG: + int_tol = tol + case TY_REAL: + real_tol = tol + case TY_DOUBLE: + dbl_tol = tol + } + + idx = 1 + jdx = 1 + kdx = 1 + + nmerge = 0 + while (idx <= nidx[1] && jdx <= nidx[2]) { + + # Calculate addresses of array elements + + ptr1 = aryptr[1] + lendata[1] * (Memi[idxptr[1]+idx-1] - 1) + ptr2 = aryptr[2] + lendata[2] * (Memi[idxptr[2]+jdx-1] - 1) + + # Determine relative order of the two elements + # If mem[ptr1] < mem[ptr2], order = -1 + # If mem[ptr1] == mem[ptr2], order = 0 + # If mem[ptr1] > mem[ptr2], order = 1 + + switch (spptype[1]) { + case TY_BOOL: + # false < true + + if (! Memb[ptr1] && Memb[ptr2]) + order = -1 + else if (Memb[ptr1] && ! Memb[ptr2]) + order = 1 + else + order = 0 + case TY_CHAR: + if (strlt (Memc[ptr1], Memc[ptr2])) + order = -1 + else if (strgt (Memc[ptr1], Memc[ptr2])) + order = 1 + else + order = 0 + case TY_SHORT,TY_INT, TY_LONG: + if (Memi[ptr1] + int_tol < Memi[ptr2]) + order = -1 + else if (Memi[ptr1] > Memi[ptr2] + int_tol) + order = 1 + else + order = 0 + case TY_REAL: + if (Memr[ptr1] + real_tol < Memr[ptr2]) + order = -1 + else if (Memr[ptr1] > Memr[ptr2] + real_tol) + order = 1 + else + order = 0 + case TY_DOUBLE: + if (Memd[ptr1] + dbl_tol < Memd[ptr2]) + order = -1 + else if (Memd[ptr1] > Memd[ptr2] + dbl_tol) + order = 1 + else + order = 0 + } + + # Increment the indices to the two arrays and if a match is + # found, add it to the index array. + + # The third index, kdx, tells where to fall back to when the + # value in the first array exceeds the value in the second array. + # Because the arrays are sorted in ascending order, the array + # element pointed to by idx exceeds all those previous to the + # element pointed to by kdx, so there is no use checking them. + + switch (order) { + case -1: + idx = idx + 1 + jdx = kdx + case 0: + nmerge = nmerge + 1 + if (nmerge <= nmax) { + index1[nmerge] = Memi[idxptr[1]+idx-1] + index2[nmerge] = Memi[idxptr[2]+jdx-1] + } + + # Keep fron reading past the end of the array + + if (jdx < nidx[2]) { + jdx = jdx + 1 + } else { + idx = idx + 1 + jdx = kdx + } + case 1: + jdx = jdx + 1 + kdx = jdx + } + } + +end diff --git a/pkg/utilities/nttools/lib/tblsearch.x b/pkg/utilities/nttools/lib/tblsearch.x new file mode 100644 index 00000000..87e17106 --- /dev/null +++ b/pkg/utilities/nttools/lib/tblsearch.x @@ -0,0 +1,104 @@ +include +include +include +include "reloperr.h" + +# TBL_SEARCH -- Search table for a row which makes an expression true +# +# This procedure evaluates a boolean expession for the indicated rows in a +# table. When it finds a row which makes the expression true, it returns +# the row number. If it does not find any such row, it returns zero. If +# there is a syntax error in the expression, it returns ERR. +# +# B.Simon 13-Apr-1988 First Code +# Phil Hodge 4-Mar-2002 Free memory allocated by evexpr. +# Phil Hodge 23-Apr-2002 Move xev_freeop and mfree. + +int procedure tbl_search (tp, expr, first, last) + +pointer tp # i: Table descriptor +char expr[ARB] # i: Boolean expression used in search +int first # i: First row to look at +int last # i: Last row to look at +#-- +include "tblterm.com" + +int old_handler, tbl_term_adr, tbl_func_adr +int status, found, dir, iary, junk +pointer sp, op, newexp +bool done + +int locpr(), errcode() +pointer evexpr() + +extern tbl_handler(), tbl_term(), tbl_func() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (newexp, SZ_COMMAND, TY_CHAR) + + # Convert Fortran relational operators to SPP + + call ftnexpr (expr, Memc[newexp], SZ_COMMAND) + + # Set up error handler to catch arithmetic errors + + call xwhen (X_ARITH, locpr(tbl_handler), old_handler) + + table = tp + nterm = 0 + constant = false + + tbl_term_adr = locpr (tbl_term) + tbl_func_adr = locpr (tbl_func) + + found = 0 + done = false + + dir = sign (1, last - first) + do iary = first, last, dir { + + irow = iary + iterm = 0 + + # Execution will resume here when an arithmetic error occurs + + call zsvjmp (jumpbuf, status) + + if (status != OK) + next + + # Evaluate expression. Check if result is true + + ifnoerr { + op = evexpr (Memc[newexp], tbl_term_adr, tbl_func_adr) + } then { + + if (O_TYPE(op) != TY_BOOL) { + found = ERR + done = true + } else if (O_VALB(op)) { + found = irow + done = true + } + call xev_freeop (op) + call mfree (op, TY_STRUCT) + + } else if (errcode() != PUTNULL) { + # Ignore errors caused by nulls + found = ERR + done = true + } + if (done) + break + } + + # Restore old error handler + + call xwhen (X_ARITH, old_handler, junk) + call sfree (sp) + + return (found) +end diff --git a/pkg/utilities/nttools/lib/tblsort.x b/pkg/utilities/nttools/lib/tblsort.x new file mode 100644 index 00000000..9af87bf6 --- /dev/null +++ b/pkg/utilities/nttools/lib/tblsort.x @@ -0,0 +1,39 @@ +# TBL_SORT -- Sort a table on selected table columns +# +# B.Simon 06-Fab-90 First Code + +procedure tbl_sort (ascend, casesens, tp, numptr, colptr, nindex, index) + +bool ascend # i: Sort in ascending order +bool casesens # i: Sort is case sensitive +pointer tp # i: Table descriptor +int numptr # i: Number of columns to sort on +pointer colptr[ARB] # i: Array of column descriptors +int nindex # i: Number of elements in index array +int index[ARB] # io: Array of row indices to sort +#-- +bool fold +int idx, jdx, temp + +begin + # Call the sort routine in the table library + + fold = ! casesens + call tbtsrt (tp, numptr, colptr, fold, nindex, index) + + # Reorder the index array if ascend is false + + if (! ascend) { + idx = 1 + jdx = nindex + while (idx < jdx) { + temp = index[idx] + index[idx] = index[jdx] + index[jdx] = temp + idx = idx + 1 + jdx = jdx - 1 + } + } + + +end diff --git a/pkg/utilities/nttools/lib/tblsort1.x b/pkg/utilities/nttools/lib/tblsort1.x new file mode 100644 index 00000000..5d68751b --- /dev/null +++ b/pkg/utilities/nttools/lib/tblsort1.x @@ -0,0 +1,157 @@ +include "reloperr.h" + +.help tbl_sort1 +.nf____________________________________________________________________________ + +This file contains two routines that sort a table on a single column. Both +routines put an existing array of row indices into sorted order. The first +routine, tbl_sort1 has a simpler interface and is the routine to be used in +a majority of cases. The second routine, tbl_qsort, requires that the calling +routine read the table column into an array and handle null elements by +itself. This routine should be used if the table column requires some +special preprocessing before it can be sorted. One example of required +preprocessing is conversion of dates from character strings to julian dates. +Both routines use quick sort to sort the data. Quick is one of the fastest +sorting routines, but it cannot be used to sort several table columns because +it is not stable. This means that one sort destroys the ordering of a previous +sort on a different column. + +.endhelp_______________________________________________________________________ + +# TBL_SORT1 -- Sort a table on a single column +# +# This procedure rearranges an array of row indices into sorted order. The +# order is from smallest to largest value if ascend is true, if ascend is +# false, the order is from largest to smallest. In either case undefined +# elements will be last in the array. For purposes of this routine boolean +# false is considered to be less than true. If character strings are being +# sorted, case can be ignored by setting casesens to false. The array of row +# indices must be created before calling this procedure. +# +# B.Simon 16-Sept-87 First Code +# B.Simon 15-Dec-87 Changed to handle table subsets + +procedure tbl_sort1 (ascend, casesens, tp, cp, nindex, index) + +bool ascend # i: Sort in ascending order +bool casesens # i: Sort is case sensitive +pointer tp # i: Table descriptor +pointer cp # i: Column descriptor +int nindex # io: Number of rows +int index[ARB] # io: Array of row pointers in sorted order +#-- +int dtype, spptype, lendata +int nary, iary, nelem +pointer idxptr, nulptr, aryptr, curptr + +int movenulls() + +begin + # Allocate storage for index array + + call malloc (idxptr, nindex, TY_INT) + + # Initialize the array of row indices + + call amovi (index, Memi[idxptr], nindex) + + # Read in the column of table values. Setting dtype to + # zero gets the actual data type of the column + + dtype = 0 + call gettabcol (tp, cp, dtype, nary, aryptr, nulptr) + + if (dtype < 0) { + lendata = - dtype + spptype = TY_CHAR + + if (! casesens) { + curptr = aryptr + do iary = 1, nary { + call strupr (Memc[curptr]) + curptr = curptr + lendata + 1 + } + } + } else { + lendata = 1 + spptype = dtype + } + + # Move all null elements to the end of the array + + nelem = movenulls (nindex, Memb[nulptr], Memi[idxptr]) + + # Perform an indirect sort on the row indices using quicksort + + call tbl_qsort (ascend, dtype, aryptr, nelem, idxptr) + + # Move the row indices into the output array + + call amovi (Memi[idxptr], index, nindex) + + call mfree (idxptr, TY_INT) + call mfree (nulptr, TY_BOOL) + call mfree (aryptr, spptype) + +end + +# TBL_QSORT -- Indirect quick sort of a table column using an index array + +procedure tbl_qsort (ascend, dtype, aryptr, nelem, idxptr) + +bool ascend # i: Sort array in ascending order +int dtype # i: Data type of array to be sorted +pointer aryptr # i: Pointer to array to be sorted +int nelem # i: Number of elements to be sorted +pointer idxptr # o: Pointer to array of indices + +include "compare.com" + +int spptype + +extern compascb, compascd, compasci, compascr, compasct +extern compdscb, compdscd, compdsci, compdscr, compdsct + +begin + dataptr = aryptr + + # Convert the type to the SPP format + + if (dtype < 0) { + lendata = - dtype + spptype = TY_CHAR + } else { + lendata = 1 + spptype = dtype + } + + # Call the quick sort procedure with the proper comparison routine + + switch (spptype) { + case TY_BOOL: + if (ascend) + call qsort (Memi[idxptr], nelem, compascb) + else + call qsort (Memi[idxptr], nelem, compdscb) + case TY_CHAR: + if (ascend) + call qsort (Memi[idxptr], nelem, compasct) + else + call qsort (Memi[idxptr], nelem, compdsct) + case TY_SHORT,TY_INT,TY_LONG: + if (ascend) + call qsort (Memi[idxptr], nelem, compasci) + else + call qsort (Memi[idxptr], nelem, compdsci) + case TY_REAL: + if (ascend) + call qsort (Memi[idxptr], nelem, compascr) + else + call qsort (Memi[idxptr], nelem, compdscr) + case TY_DOUBLE: + if (ascend) + call qsort (Memi[idxptr], nelem, compascd) + else + call qsort (Memi[idxptr], nelem, compdscd) + } +end diff --git a/pkg/utilities/nttools/lib/tblsortm.x b/pkg/utilities/nttools/lib/tblsortm.x new file mode 100644 index 00000000..1ece995d --- /dev/null +++ b/pkg/utilities/nttools/lib/tblsortm.x @@ -0,0 +1,168 @@ +include "reloperr.h" + +.help tbl_sortm +.nf____________________________________________________________________________ + +This file contains two routines that sort a table on multiple columns. Both +routines put an existing array of row indices into sorted order. The first +routine, tbl_sortm has a simpler interface and is the routine to be used in +a majority of cases. The second routine, tbl_msort, requires that the calling +routine read the table column into an array and handle null elements by +itself. This routine should be used if the table column requires some +special preprocessing before it can be sorted. One example of required +preprocessing is conversion of dates from character strings to julian dates. +Both routines use merge sort to sort the data. Merge sort is fast, though not +as fast as quick sort, and stable, so it can be used to sort on multiple +columns. Its disadvantage is that it requires additional work space to run. + +.endhelp_______________________________________________________________________ + +# TBL_SORTM -- Sort a table on multiple columns +# +# This procedure rearranges an array of row indices into sorted order. The +# order is from smallest to largest value if ascend is true, if ascend is +# false, the order is from largest to smallest. In either case undefined +# elements will be last in the array. For purposes of this routine boolean +# false is considered to be less than true. If character strings are being +# sorted, case can be ignored by setting casesens to false. The array of row +# indices must be created before calling this procedure. +# +# B.Simon 28-Sept-87 First Code +# B.Simon 15-Dec-87 Changed to handle table subsets + +procedure tbl_sortm (ascend, casesens, tp, numptr, colptr, nindex, index) + +bool ascend # i: Sort in ascending order +bool casesens # i: Sort is case sensitive +pointer tp # i: Table descriptor +int numptr # i: Number of columns to sort on +pointer colptr[ARB] # i: Array of column descriptors +int nindex # io: Number of rows +int index[ARB] # io: Array of row indices in sorted order +#-- +int dtype, spptype, lendata +int iptr, nary, iary, nelem, nidx +pointer cp, idxptr, nulptr, aryptr, curptr + +int movenulls() + +begin + # Allocate storage for index array + + nidx = 2 * nindex + call malloc (idxptr, nidx, TY_INT) + + # Initialize the array of row indices + + call amovi (index, Memi[idxptr], nindex) + + # Loop over all columns to be sorted + + do iptr = numptr, 1, -1 { + + cp = colptr(iptr) + + # Read in the column of table values. Setting dtype to zero + # gets the actual column type. + + dtype = 0 + call gettabcol (tp, cp, dtype, nary, aryptr, nulptr) + + if (dtype < 0) { + lendata = - dtype + spptype = TY_CHAR + + if (! casesens) { + curptr = aryptr + do iary = 1, nary { + call strupr (Memc[curptr]) + curptr = curptr + lendata + 1 + } + } + } else { + lendata = 1 + spptype = dtype + } + + # Move all null elements to the end of the array + + nelem = movenulls (nindex, Memb[nulptr], Memi[idxptr]) + + # Perform an indirect sort on the row indices using merge sort + + call tbl_msort (ascend, dtype, aryptr, nelem, nidx, idxptr) + + # Free memory used to hold table column and null flags + + call mfree (aryptr, spptype) + call mfree (nulptr, TY_BOOL) + } + + # Move the row indices into the output array + + call amovi (Memi[idxptr], index, nindex) + call mfree (idxptr, TY_INT) + +end + +# TBL_MSORT -- Indirect merge sort of a table column using an index array + +procedure tbl_msort (ascend, dtype, aryptr, nelem, nidx, idxptr) + +bool ascend # i: Sort array in ascending order +int dtype # i: Data type of array to be sorted +pointer aryptr # i: Pointer to array to be sorted +int nelem # i: Number of array elements to be sorted +int nidx # i: Size of index array +pointer idxptr # o: Pointer to array of indices + +include "compare.com" + +int spptype + +extern compascb, compascd, compasci, compascr, compasct +extern compdscb, compdscd, compdsci, compdscr, compdsct + +begin + dataptr = aryptr + + if (dtype < 0) { + lendata = - dtype + spptype = TY_CHAR + } else { + lendata = 1 + spptype = dtype + } + + # Convert the type to the SPP format + + # Call the merge sort procedure with the proper comparison routine + + switch (spptype) { + case TY_BOOL: + if (ascend) + call msort (Memi[idxptr], nidx, nelem, compascb) + else + call msort (Memi[idxptr], nidx, nelem, compdscb) + case TY_CHAR: + if (ascend) + call msort (Memi[idxptr], nidx, nelem, compasct) + else + call msort (Memi[idxptr], nidx, nelem, compdsct) + case TY_SHORT,TY_INT,TY_LONG: + if (ascend) + call msort (Memi[idxptr], nidx, nelem, compasci) + else + call msort (Memi[idxptr], nidx, nelem, compdsci) + case TY_REAL: + if (ascend) + call msort (Memi[idxptr], nidx, nelem, compascr) + else + call msort (Memi[idxptr], nidx, nelem, compdscr) + case TY_DOUBLE: + if (ascend) + call msort (Memi[idxptr], nidx, nelem, compascd) + else + call msort (Memi[idxptr], nidx, nelem, compdscd) + } +end diff --git a/pkg/utilities/nttools/lib/tblterm.com b/pkg/utilities/nttools/lib/tblterm.com new file mode 100644 index 00000000..56d6c564 --- /dev/null +++ b/pkg/utilities/nttools/lib/tblterm.com @@ -0,0 +1,7 @@ +int jumpbuf[LEN_JUMPBUF] +common /jmpcom/ jumpbuf + +bool constant +int nterm, irow, iterm +pointer table +common /opcom/ constant, nterm, irow, iterm, table diff --git a/pkg/utilities/nttools/lib/tblterm.x b/pkg/utilities/nttools/lib/tblterm.x new file mode 100644 index 00000000..65904221 --- /dev/null +++ b/pkg/utilities/nttools/lib/tblterm.x @@ -0,0 +1,256 @@ +include +include +include +include +include "reloperr.h" + +define MAXTERM 64 + +# TBL_TERM -- Return the value of the term in the expression +# +# B.Simon 13-Apr-88 Separated from tbl_eval + +procedure tbl_term (term, op) + +char term[ARB] # i: The name of the term +pointer op # o: A structure holding the term value and type +#-- +include "tblterm.com" + +bool isnull +int datalen[MAXTERM], datatype[MAXTERM], dtype +pointer colptr[MAXTERM] +pointer sp, errtxt + +string badname "Column name not found (%s)" +string badnum "Too many terms in expression" +string nulvalue "Null found in table element" + +int tbcigi() + +errchk tbcfnd, tbcigi, tbegtb, tbegtt, tbegti, tbegtr + +begin + # Allocate storage for character strings + + call smark (sp) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + constant = false + iterm = iterm + 1 + if (iterm > MAXTERM) + call error (BOUNDS, badnum) + + # If this is a new term, get its column pointer, type, and length + + if (iterm > nterm) { + nterm = iterm + call tbcfnd (table, term, colptr[iterm], 1) + + if (colptr[iterm] == NULL) { + call sprintf (Memc[errtxt], SZ_LINE, badname) + call pargstr (term) + call error (SYNTAX, Memc[errtxt]) + } + + dtype = tbcigi (colptr[iterm], TBL_COL_DATATYPE) + switch (dtype) { + case TY_BOOL: + datalen[iterm] = 0 + datatype[iterm] = TY_BOOL + case TY_CHAR: + datalen[iterm] = 1 + datatype[iterm] = TY_CHAR + case TY_SHORT,TY_INT,TY_LONG: + datalen[iterm] = 0 + datatype[iterm] = TY_INT + case TY_REAL,TY_DOUBLE: + datalen[iterm] = 0 + datatype[iterm] = TY_REAL + default: + datalen[iterm] = - dtype + datatype[iterm] = TY_CHAR + } + } + + # Read the table to get the value of term + + call xev_initop (op, datalen[iterm], datatype[iterm]) + + switch (datatype[iterm]) { + case TY_BOOL: + call tbegtb (table, colptr[iterm], irow, O_VALB(op)) + isnull = false + case TY_CHAR: + call tbegtt (table, colptr[iterm], irow, O_VALC(op), + datalen[iterm]) + isnull = O_VALC(op) == EOS + case TY_SHORT,TY_INT,TY_LONG: + call tbegti (table, colptr[iterm], irow, O_VALI(op)) + isnull = IS_INDEFI (O_VALI(op)) + case TY_REAL,TY_DOUBLE: + call tbegtr (table, colptr[iterm], irow, O_VALR(op)) + isnull = IS_INDEFR (O_VALR(op)) + } + + # Error exit if table element is null + + if (isnull) + call error (PUTNULL, nulvalue) + + call sfree (sp) +end + +# TBL_FUNC -- Return the value of a nonstandard function in the expression + +procedure tbl_func (func_name, arg_ptr, nargs, op) + +char func_name[ARB] # i: String containing function name +pointer arg_ptr[ARB] # i: Pointers to function arguments +int nargs # i: Number of function arguments +pointer op # o: Pointer to output structure +#-- +include "tblterm.com" + +bool valflag +int type, iarg +pointer sp, errtxt + +string badtyp "Invalid argument type in %s" +string badarg "Incorrect number of arguments for %s" +string badfun "Unknown function named %s" + +bool streq() +double mjd() + +errchk mjd() + +begin + # Allocate storage for character strings + + call smark (sp) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Call appropriate function according to name + + if (streq (func_name, "row")) { + + # Table row number function: row() + + constant = false + if (nargs != 0) { + call sprintf (Memc[errtxt], SZ_LINE, badarg) + call pargstr (func_name) + call error (SYNTAX, Memc[errtxt]) + } + call xev_initop (op, 0, TY_INT) + O_VALI(op) = irow + + } else if (streq (func_name, "delta")) { + + # Difference between two Julian dates: mjd(date1) - mjd(date2) + + if (nargs != 2) { + call sprintf (Memc[errtxt], SZ_LINE, badarg) + call pargstr (func_name) + call error (SYNTAX, Memc[errtxt]) + } + if (O_TYPE(arg_ptr[1]) != TY_CHAR || + O_TYPE(arg_ptr[2]) != TY_CHAR ) { + call sprintf (Memc[errtxt], SZ_LINE, badtyp) + call pargstr (func_name) + call error (SYNTAX, Memc[errtxt]) + } + call xev_initop (op, 0, TY_REAL) + O_VALR(op) = mjd (O_VALC(arg_ptr[1])) - mjd (O_VALC(arg_ptr[2])) + + } else if (streq (func_name, "match")) { + if (nargs < 2) { + call sprintf (Memc[errtxt], SZ_LINE, badarg) + call pargstr (func_name) + call error (SYNTAX, Memc[errtxt]) + } + + type = O_TYPE(arg_ptr[1]) + do iarg = 2, nargs { + if (type != O_TYPE(arg_ptr[iarg])) { + call sprintf (Memc[errtxt], SZ_LINE, badtyp) + call pargstr (func_name) + call error (SYNTAX, Memc[errtxt]) + } + } + + valflag = false + call xev_initop (op, 0, TY_BOOL) + + switch (type) { + case TY_BOOL: + if (O_VALB(arg_ptr[1])) { + do iarg = 2, nargs { + if (O_VALB(arg_ptr[iarg])) { + valflag = true + break + } + } + } else { + do iarg = 2, nargs { + if (! O_VALB(arg_ptr[iarg])) { + valflag = true + break + } + } + } + case TY_CHAR: + do iarg = 2, nargs { + if (streq (O_VALC(arg_ptr[1]), O_VALC(arg_ptr[iarg]))) { + valflag = true + break + } + } + case TY_SHORT,TY_INT,TY_LONG: + do iarg = 2, nargs { + if (O_VALI(arg_ptr[1]) == O_VALI(arg_ptr[iarg])) { + valflag = true + break + } + } + case TY_REAL: + do iarg = 2, nargs { + if (O_VALR(arg_ptr[1]) == O_VALR(arg_ptr[iarg])) { + valflag = true + break + } + } + } + O_VALB(op) = valflag + + } else { + + call sprintf (Memc[errtxt], SZ_LINE, badfun) + call pargstr (func_name) + call error (SYNTAX, Memc[errtxt]) + + } + + call sfree (sp) +end + +# TBL_HANDLER -- Error handler to catch arithmetic errors + +procedure tbl_handler (code, nxt_handler) + +int code # i: error code which trigerred this exception +int nxt_handler # o: handler called after this handler exits +#-- +include "tblterm.com" + +bool junk +bool xerpop() + +begin + # Resume execution at zsvjmp + + nxt_handler = X_IGNORE + junk = xerpop() + call zdojmp (jumpbuf, code) +end diff --git a/pkg/utilities/nttools/lib/tctexp.x b/pkg/utilities/nttools/lib/tctexp.x new file mode 100644 index 00000000..263b18bc --- /dev/null +++ b/pkg/utilities/nttools/lib/tctexp.x @@ -0,0 +1,442 @@ +include +include +include "reloperr.h" + +define MAX_STACK 8 +define BLANK ' ' +define DELIM ',' +define ESCAPE '\\' +define NEGCHAR '~' # negation character +define ALT_NEGCHAR '!' # alternate negation character + +.help tctexp +.nf___________________________________________________________________________ +Column template package + +This package contains subroutines to expand a column name template into +an array of column pointers which match the template. The template is a +list of column patterns separated by commas or whitespace. The column +pattern is either a column name, a file name containing a list of column +names, or a pattern using the usual IRAF pattern matching syntax. For +example, the string + + a[1-9], b, time*, @column.lis + +would be expanded as the column names a1 through a9, b, any column name +beginning with "time", and all the column names in the file column.lis. +If the column template is entirely whitespace, the array of column pointers +will include all the columns in the table, as this seems the most reasonable +default. If the first non-white character is the negation character (~), +the array of column pointers will include all columns not matched by the +template. The negation character only has this meaning as the first character +in the column template, and is interpreted as part of a column name if +found later in the template or in a file. + +.endhelp______________________________________________________________________ + +# TCTEXP -- Expand a column template into an array of column pointers +# +# Given a table pointed to by a table descriptor and a column name template, +# return an array of column pointers. The size of the column pointer array +# is given by numcol and should be greater than or equal to the number of +# columns in the table. The actual number of columns found that match the +# template is returned as numptr. +# +# B.Simon 24-Jul-1987 First Code +# Phil Hodge 1-Jun-1989 make search for columns case insensitive +# Phil Hodge 28-Jan-1999 add ! as an alternate negation character + +procedure tctexp (tp, template, numcol, numptr, colptr) + +pointer tp # i: pointer to table descriptor +char template[ARB] # i: column template +int numcol # i: size of column pointer array +int numptr # o: number of columns matched +pointer colptr[ARB] # o: array of column pointers +#-- + +bool nometa # true if pattern does not contain metacharacters +bool negate # true if template starts with negation character + +int fd_ptr # pointer to stack of open list file descriptors +int ic # first non-white character in template + +pointer fd_stack[MAX_STACK] + # stack of file descriptors for open list files + +pointer sp, colpat, pattern, auxcol, fd + +string stkovflerr "List files are nested too deeply, stack overflow" + +int strlen(), tctgetpat() +pointer stropen(), open() + +errchk salloc, stropen, open, close +errchk tctgetpat, tctmakpat, tctstrmatch, tctpatmatch + +begin + numptr = 0 + negate = false + + call smark (sp) + call salloc (colpat, SZ_FNAME, TY_CHAR) + call salloc (pattern, SZ_FNAME, TY_CHAR) + + # Check the column name template to find the first non-white character. + + for (ic = 1; IS_WHITE (template[ic]); ic = ic + 1) + ; + + if (template[ic] == EOS) { + + # If the template is blank, include all columns in the array + + call allcolumns (tp, numptr, auxcol) + call amovi (Memi[auxcol], colptr, numptr) + call mfree (auxcol, TY_INT) + fd_ptr = 0 + + } else { + + # If the first non-white character is the negation character + # (either ~ or !), the meaning of the column name template is + # negated, that is, the array of column pointers will include + # those columns whose names were not matched by the column template + + if (template[ic] == NEGCHAR || template[ic] == ALT_NEGCHAR) { + negate = true + ic = ic + 1 + } + + # Open the column name template as a file and push on + # the list file stack + + fd_ptr = 1 + fd_stack[1] = + stropen (template[ic], strlen(template[ic]), READ_ONLY) + + } + + while (fd_ptr > 0) { + + # Pop file descriptor off of the list file stack + + fd = fd_stack[fd_ptr] + fd_ptr = fd_ptr - 1 + + # Loop over all column patterns in the file + + while (tctgetpat (fd, Memc[colpat], SZ_FNAME) > 0) { + + if (Memc[colpat] == '@') { + + # If this pattern is a list file name, push the + # current descriptor on the stack and open the file + + if (fd_ptr == MAX_STACK) + call error (BOUNDS, stkovflerr) + fd_ptr = fd_ptr + 1 + fd_stack[fd_ptr] = fd + fd = open (Memc[colpat+1], READ_ONLY, TEXT_FILE) + + } else { + + # Otherwise, encode the pattern and search the table + # for matching column names. To speed the search, use + # a special routine if the pattern does not include + # metacharacters + + call strlwr (Memc[colpat]) # for case insensitivity + call tctmakpat (Memc[colpat], Memc[pattern], SZ_FNAME, + nometa) + if (nometa) + call tctstrmatch (tp, Memc[pattern], numcol, + numptr, colptr) + else + call tctpatmatch (tp, Memc[pattern], numcol, + numptr, colptr) + } + } + call close (fd) + } + + if (negate) + call invert (tp, numptr, colptr) + + call sfree (sp) +end + +# TCTGETPAT -- Get next comma or whitespace delimeted pattern from file +# +# Copy characters into colpat until a field delimeter or the maximum number of +# characters is reached. The number of characters in colpat is returned as the +# value of the function, so the procedure which calls this one can test for +# the last field in the template. +# +# B. Simon 24-Jul-87 First Code + +int procedure tctgetpat (fd, colpat, maxch) + +pointer fd # i: template file descriptor +char colpat[ARB] # o: pattern from column name template +int maxch # i: maximum number of characters in field +#-- +char ch # next character from template +int iq # pointer to character in colpat + +char getc() + +begin + # Skip leading whitespace or commas + + ch = getc (fd, ch) + while (IS_CNTRL(ch) || ch == BLANK || ch == DELIM) + ch = getc (fd, ch) + + # Copy characters to colpat. End when maxch is reached, or + # when comma, whitespace, or EOF is found + + for (iq = 1; iq <= maxch; iq = iq + 1) { + + if (IS_CNTRL(ch) || ch == BLANK || ch == DELIM || ch == EOF) + break + + colpat[iq] = ch + ch = getc (fd, ch) + } + colpat[iq] = EOS + + # If loop is terminated because of maxch, eat remaining characters + # in field + + while (! IS_CNTRL(ch) && ch != BLANK && ch != DELIM && ch != EOF) + ch = getc (fd, ch) + + # Return number of characters in colpat + + return (iq-1) +end + +# TCTMAKPAT -- Encode the column pattern +# +# Create the pattern used by the matching routines. Check for metacharacters +# (unescaped pattern matching characters) to see if the faster constant +# pattern routine can be used. +# +# B.Simon 24-Jul-87 First Code + +procedure tctmakpat (colpat, pattern, maxch, nometa) + +char colpat[ARB] # i: Column pattern string +char pattern[ARB] # o: Encoded pattern string +int maxch # i: Maximum length of encoded pattern string +bool nometa # o: True if no metacharacters in string +#-- +int ic, ip +pointer sp, buffer, buffer2, errtxt, ib + +int stridx(), strlen(), patmake() + +string patovflerr "Column pattern too long (%s)" +string badpaterr "Column pattern has bad syntax (%s)" + +begin + call smark (sp) + call salloc (buffer, maxch, TY_CHAR) + call salloc (buffer2, maxch, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + nometa = true + ib = buffer + + # Copy the column pattern to a temporary buffer + + for (ic = 1; colpat[ic] != EOS ; ic = ic + 1) { + + # Copy escape sequences, but do not count as metacharacters + + if (colpat[ic] == ESCAPE && colpat[ic+1] != EOS) { + Memc[ib] = ESCAPE + ib = ib + 1 + ic = ic + 1 + + # Covert '*' to '?*', count as a metacharacter + + } else if (colpat[ic] == '*') { + nometa = false + Memc[ib] = '?' + ib = ib + 1 + + # Check for the other metacharacters + + } else if (stridx (colpat[ic], "[?{") > 0) + nometa = false + + Memc[ib] = colpat[ic] + ib = ib + 1 + } + Memc[ib] = EOS + + # Check the buffer length against maximum pattern length + + if (strlen (Memc[buffer]) > maxch) { + call sprintf (Memc[errtxt], SZ_LINE, patovflerr) + call pargstr (colpat) + call error (BOUNDS, Memc[errtxt]) + } + + # If no metacharacters, strip escape sequences + + if (nometa) { + ip = 1 + for (ib = buffer; Memc[ib] != EOS; ib = ib + 1) { + if (Memc[ib] == ESCAPE && Memc[ib+1] != EOS) + ib = ib + 1 + pattern[ip] = Memc[ib] + ip = ip + 1 + } + pattern[ip] = EOS + + # Otherwise, encode with patmake + + } else { + call sprintf (Memc[buffer2], maxch, "^%s$") + call pargstr (Memc[buffer]) + + if (patmake (Memc[buffer2], pattern, SZ_LINE) == ERR) { + call sprintf (Memc[errtxt], SZ_LINE, badpaterr) + call pargstr (colpat) + call error (SYNTAX, Memc[errtxt]) + } + } + + call sfree (sp) +end + +# TCTSTRMATCH -- Add a column pointer for a column name to the array +# +# Used to match column names when the column pattern contains no +# metacharacters. +# +# B. Simon 24-Jul-87 First Code + +procedure tctstrmatch (tp, pattern, numcol, numptr, colptr) + +pointer tp # i: pointer to table descriptor +char pattern[ARB] # i: column pattern +int numcol # i: size of column pointer array +int numptr # o: number of columns matched +pointer colptr[ARB] # o: array of column pointers +#-- +int iptr +pointer sp, errtxt, cp + +string maxcolerr "Maximum number of columns in table exceeded (%d)" + +errchk tbcfnd + +begin + call smark (sp) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Find the column pointer corresponding to the column name + + call tbcfnd (tp, pattern, cp, 1) + + # Pointer is null if column not found in table + + if (cp == NULL) + return + + # See if the column name has already been matched + + for (iptr = 1; iptr <= numptr; iptr = iptr +1) { + if (cp == colptr[iptr]) + break + } + + # If not, add its pointer in the array of pointers + # after checking for array overflow + + if (iptr > numptr) { + if (numptr >= numcol) { + call sprintf (Memc[errtxt], SZ_LINE, maxcolerr) + call pargi (numcol) + call error (BOUNDS, Memc[errtxt]) + } + numptr = numptr + 1 + colptr[numptr] = cp + } + + call sfree (sp) +end + +# TCTPATMATCH -- Find column pointers for columns matching a pattern +# +# This routine is called when the column pattern contains metacharacters. +# +# B.Simon 27-Jul-87 First Code + +procedure tctpatmatch (tp, pattern, numcol, numptr, colptr) + +pointer tp # i: pointer to table descriptor +char pattern[ARB] # i: column pattern +int numcol # i: size of column pointer array +int numptr # o: number of columns matched +pointer colptr[ARB] # o: array of column pointers +#-- +int maxcol, icol, iptr +pointer sp, errtxt, cp +pointer colname + +string maxcolerr "Maximum number of columns in table exceeded (%d)" + +int tbpsta(), tbcnum(), patmatch() + +errchk tbpsta, tbcnum, tbcinf, patmatch + +begin + call smark (sp) + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + maxcol = tbpsta (tp, TBL_NCOLS) + + # Compare the column pattern to each column name in the table + + do icol = 1, maxcol { + + # Get the next column name in the table + + cp = tbcnum (tp, icol) + call tbcigt (cp, TBL_COL_NAME, Memc[colname], SZ_COLNAME) + call strlwr (Memc[colname]) # for case insensitivity + + # Check the column name for a match + + if (patmatch (Memc[colname], pattern) > 0) { + # See if the column name has already been matched + + for (iptr = 1; iptr <= numptr; iptr = iptr +1) { + if (cp == colptr[iptr]) + break + } + + # If not, add its pointer in the array of pointers + # after checking for array overflow + + if (iptr > numptr) { + if (numptr >= numcol) { + call sprintf (Memc[errtxt], SZ_LINE, maxcolerr) + call pargi (numcol) + call error (BOUNDS, Memc[errtxt]) + } + numptr = numptr + 1 + colptr[numptr] = cp + } + } + } + + call sfree (sp) + +end diff --git a/pkg/utilities/nttools/lib/tldtype.x b/pkg/utilities/nttools/lib/tldtype.x new file mode 100644 index 00000000..52e35960 --- /dev/null +++ b/pkg/utilities/nttools/lib/tldtype.x @@ -0,0 +1,70 @@ +define T_MAXDIM 7 # maximum dimension of array + +# tl_dtype -- data type and array size +# Convert integer data type code to a character string. If the column +# contains arrays, append the length of each axis, e.g. R[25,75]. +# +# Phil Hodge, 9-Dec-1994 Moved from tlcol.x to ttools$lib/. +# Phil Hodge, 19-Jul-1995 Add tp to calling sequence (needed for tbciga). + +procedure tl_dtype (tp, cp, datatype, nelem, chartyp, maxch) + +pointer tp # i: pointer to table descriptor +pointer cp # i: pointer to column descriptor +int datatype # i: integer code for data type +int nelem # i: total array size +char chartyp[maxch] # o: data type, possibly with array size +int maxch # i: maximum size of chartyp string +#-- +int nchar # number of characters +int i # loop index +int ndim # dimension of array +int axlen[T_MAXDIM] # length of each axis +int ip, itoc() +int strlen() +errchk tbciga + +begin + if (datatype > 0) { # numeric or Boolean + + switch (datatype) { + case TY_REAL: + call strcpy ("R", chartyp, maxch) + case TY_DOUBLE: + call strcpy ("D", chartyp, maxch) + case TY_INT: + call strcpy ("I", chartyp, maxch) + case TY_SHORT: + call strcpy ("S", chartyp, maxch) + case TY_BOOL: + call strcpy ("B", chartyp, maxch) + default: + call error (1, "bad data type in table") + } + + } else { # < 0 ==> char string + + nchar = -datatype # length of string + call sprintf (chartyp, maxch, "CH*%d") + call pargi (nchar) + } + + if (nelem > 1) { + + # Get the dimension of array and size of each axis. + call tbciga (tp, cp, ndim, axlen, T_MAXDIM) + + call strcat ("[", chartyp, maxch) + + ip = strlen (chartyp) + 1 # points to EOS + + do i = 1, ndim-1 { + nchar = itoc (axlen[i], chartyp[ip], maxch-ip+1) + call strcat (",", chartyp, maxch) + ip = ip + nchar + 1 + } + + nchar = itoc (axlen[ndim], chartyp[ip], maxch-ip+1) + call strcat ("]", chartyp, maxch) + } +end diff --git a/pkg/utilities/nttools/lib/tuopen.x b/pkg/utilities/nttools/lib/tuopen.x new file mode 100644 index 00000000..7434a72b --- /dev/null +++ b/pkg/utilities/nttools/lib/tuopen.x @@ -0,0 +1,197 @@ +# This file contains tu_open and tu_close, which are used to open +# and close a temporary table. +# +# Phil Hodge, 28-Jun-1995 Subroutines created based on Bernie's tedit code. +# Phil hodge, 16-Apr-1999 Remove ttype from calling sequence of tbparse. + +# tu_open -- open a temporary table +# If the table is to be opened in-place, then it's just opened. +# Otherwise, a copy of the table is made, and that table is opened +# read-write. The name of the original table will be returned as +# 'tabname' so it can be passed to tu_close, which needs the name of +# the original file. If the filename extension is ".tab", then 'table' +# might not include the extension. This is the reason we need a +# separate output argument 'tabname'. Note, however, that text tables +# need not have an extension. If 'table' does not include an extension, +# and a file of that name exists, then ".tab" will not be appended when +# copying to 'tabname'. 'tabname' can differ from the actual file name +# by including a name or number in brackets after the file name. +# +# Note that it is an error if readonly=true but inplace=false. + +procedure tu_open (table, root, readonly, inplace, tp, tabname, maxch) + +char table[ARB] # i: name of table +char root[ARB] # i: beginning of name for scratch file +bool readonly # i: true if the table is to be opened read-only +bool inplace # i: true if the table is to be opened in-place +pointer tp # o: pointer to table struct +char tabname[maxch] # o: full name of original table (incl extension, etc) +int maxch # i: size of filename string +#-- +pointer sp +pointer temp # name of temporary table +pointer tname, fname # full table and file names +pointer extn # file extension, or EOS +pointer tempdir # name of directory for temporary copy +pointer errmess # scratch for error message +int tlen, flen # length of table and file names +int try # loop index +int junk, fnldir() +pointer tbtopn() +int strlen() +errchk tbtopn, tbtnam, tbfile, fcopy + +begin + if (readonly && !inplace) + call error (1, "readonly = yes, but inplace = no") + + if (inplace) { + + if (readonly) { + tp = tbtopn (table, READ_ONLY, NULL) + } else { + tp = tbtopn (table, READ_WRITE, NULL) + } + + call tbtnam (tp, tabname, maxch) # get the full table name + + } else { + + call smark (sp) + call salloc (temp, SZ_LINE, TY_CHAR) + call salloc (tname, SZ_LINE, TY_CHAR) + call salloc (fname, SZ_LINE, TY_CHAR) + call salloc (extn, SZ_LINE, TY_CHAR) + call salloc (tempdir, SZ_LINE, TY_CHAR) + + # Get the full table name, full file name, and extension (if any) + # of the original file. Copy the table name to output. + call tbfile (table, Memc[tname], Memc[fname], Memc[extn], SZ_LINE) + call strcpy (Memc[tname], tabname, maxch) + + # Get the name of the directory containing the original file. + junk = fnldir (Memc[fname], Memc[tempdir], SZ_LINE) + + # Copy the original file to a temporary file. First try to + # make the copy in the directory containing the original file. + # If that fails then copy the file to tmp$. + do try = 1, 2 { + + # Construct the name of a temporary file by concatenating + # the directory, root, a random number, and the extension + # of the original file name. + call strcat (root, Memc[tempdir], SZ_LINE) + call mktemp (Memc[tempdir], Memc[temp], SZ_LINE) + call strcat (Memc[extn], Memc[temp], SZ_LINE) + + # Copy the file. + ifnoerr (call fcopy (Memc[fname], Memc[temp])) + break + + if (try == 1) { + # The first try failed. Copy the file to tmp$. + call strcpy ("tmp$", Memc[tempdir], SZ_LINE) + } else { + # The second try failed as well. + call salloc (errmess, SZ_LINE, TY_CHAR) + call sprintf (Memc[errmess], SZ_LINE, + "unable to make a temporary copy of %s") + call pargstr (Memc[fname]) + call error (1, Memc[errmess]) + } + } + + # If there was a bracketed expression (e.g. EXTNAME) in the + # input table name, append it to the name of the temp file + # to convert the file name to a complete table name. + tlen = strlen (Memc[tname]) + flen = strlen (Memc[fname]) + if (tlen > flen) + call strcat (Memc[tname+flen], Memc[temp], SZ_LINE) + + tp = tbtopn (Memc[temp], READ_WRITE, NULL) + + call sfree (sp) + } +end + +# tu_close -- close a temporary table +# This routine first closes the table that was edited. If it was opened +# inplace, then we have nothing further to do. Otherwise, we were editing +# a temporary copy of the original. If the command was to quit without +# saving changes, we delete the temporary file. If the command was to +# exit, saving changes, we rename the copy back to the original. +# The quit and tabname arguments will be ignored if inplace is true. + +procedure tu_close (tp, inplace, quit, tabname) + +pointer tp # i: pointer to table struct for edited table +bool inplace # i: true if the table was edited inplace +bool quit # i: true if we should quit without saving changes +char tabname[ARB] # i: name of original table (not temp copy) +#-- +pointer sp +pointer temp # name of temporary file +pointer tname # name of temporary table +pointer filename # name of original file +pointer cdfname # scratch +pointer errmess # for error message +int hdu # ignored +int junk +int errget() +int tbparse() +errchk tbparse, delete, rename + +begin + if (tp == NULL) + return + + call smark (sp) + call salloc (tname, SZ_LINE, TY_CHAR) + + # Get the name of the table that we edited, then close it. + call tbtnam (tp, Memc[tname], SZ_LINE) + call tbtclo (tp) + + if (!inplace) { + + call salloc (temp, SZ_LINE, TY_CHAR) + call salloc (filename, SZ_LINE, TY_CHAR) + call salloc (cdfname, SZ_LINE, TY_CHAR) + + # Strip off brackets (if present) to get the file name + # for the table that we edited. + junk = tbparse (Memc[tname], Memc[temp], + Memc[cdfname], SZ_LINE, hdu) + + # Strip off brackets (if present) to get the file name + # of the original table. + junk = tbparse (tabname, Memc[filename], + Memc[cdfname], SZ_LINE, hdu) + + if (quit) { + + call delete (Memc[temp]) # delete temp copy + + } else { + + iferr { + call delete (Memc[filename]) # delete original file + call rename (Memc[temp], Memc[filename]) + } then { + call salloc (errmess, SZ_LINE, TY_CHAR) + junk = errget (Memc[errmess], SZ_LINE) + call eprintf ("%s\n") + call pargstr (Memc[errmess]) + call sprintf (Memc[errmess], SZ_LINE, + "couldn't rename edited file %s to original %s\n") + call pargstr (Memc[temp]) + call pargstr (Memc[filename]) + call error (1, Memc[errmess]) + } + } + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/lib/unique.x b/pkg/utilities/nttools/lib/unique.x new file mode 100644 index 00000000..ca54f840 --- /dev/null +++ b/pkg/utilities/nttools/lib/unique.x @@ -0,0 +1,64 @@ +# UNIQUE -- Find unique rows in a table +# +# First, the table is sorted on columns input in the colptr array. The +# results are stored in the index array. Then each row in the index array +# is compared to the most recent unique row in the index array, column by +# column. If any column differs, the row is also considered to be unique. +# The index array is updated to reflect the new unique row and the number of +# unique rows is incremented. +# +# B.Simon 19-Oct-87 First Code +# B.Simon 14-Dec-87 Changed to handle table subsets +# B.Simon 06-Feb-90 Changed to use tbtsrt and tbrcmp + +procedure unique (tp, numptr, colptr, nindex, index) + +pointer tp # i: Table descriptor +int numptr # i: Number of column pointers +pointer colptr[ARB] # i: Array of column pointers +int nindex # io: Number of unique row indices returned +int index[ARB] # io: Array of unique indices +#-- +bool fold +int order, idx, jdx, n, i + +int tbrcmp() + +begin + + # Sort the array on the selected columns. The sort is in ascending + # order and case sensitive + + fold = false + call tbtsrt (tp, numptr, colptr, fold, nindex, index) + + # Search for unique rows + + jdx = 0 + n = nindex + nindex = 0 + + do i = 1, n { + idx = index[i] + + # First row is always unique + + if (i == 1) + order = 1 + else + order = tbrcmp (tp, numptr, colptr, fold, idx, jdx) + + # Update pointer to most recent unique row and modify index + # array in place + + if (order != 0) { + jdx = idx + nindex = nindex + 1 + index[nindex] = idx + } + } + + do i = nindex+1, n + index[i] = 0 + +end diff --git a/pkg/utilities/nttools/mkpkg b/pkg/utilities/nttools/mkpkg new file mode 100644 index 00000000..abd34f79 --- /dev/null +++ b/pkg/utilities/nttools/mkpkg @@ -0,0 +1,80 @@ +# Make the nttools package +# Author: CDBS, 23-NOV-1987 +# to include copyone,keyselect,lib,tcalc,tchsize,tcopy,tcreate,tedit, +# tinfo,tjoin,tmerge,tprint,tproduct,tproject,tselect,tsort,tupar, +# tintegrate application(s) +# 03-Jun-97 3-D table translators (I. Busko) +# +# Special keywords recognized by IRAF mkpkg files: +# +# mkpkg relink update object library and link +# mkpkg linkonly skip object library updates and just link +# mkpkg install move executable to lib$ +# mkpkg update update object library, link, and move to lib$ + +$call relink +$exit + +update: + $call relink + $call install + ; + +debug: + $set XFLAGS = "-fgq $(XFLAGS)" + $call relink + ; + +relink: + $update libpkg.a + $call nttools + ; + +install: + $move xx_nttools.e bin$x_nttools.e + ; + +nttools: +linkonly: + $omake x_nttools.x + $link x_nttools.o libpkg.a -lxtools -ltbtables -o xx_nttools.e + ; + +libpkg.a: + @threed + @stxtools + + @atools + @copyone + @gtedit + @imtab + @keyselect + @lib + @tcalc + @tchcol + @tchsize + @tcheck + @tcopy + @tcreate + @tdiffer + @tedit + @texpand + @thedit + @tinfo + @tintegrate + @tjoin + @tlinear + @tmatch + @tmerge + @tprint + @tproduct + @tproject + @tquery + @trebin + @tselect + @tsort + @tstat + @ttranspose + @tunits + @tupar + ; diff --git a/pkg/utilities/nttools/nttools.cl b/pkg/utilities/nttools/nttools.cl new file mode 100644 index 00000000..4b669406 --- /dev/null +++ b/pkg/utilities/nttools/nttools.cl @@ -0,0 +1,60 @@ +procedure nttools() +string mode="al" + +begin + package nttools + task gtedit, + imtab, + keypar, + keytab, + parkey, + partab, + tabim, + tabkey, + tabpar, + taextract, + tainsert, + tcalc, + tchcol, + tcheck, + tchsize, + tcopy, + tcreate, + tdelete, + tdiffer, + tdump, + tedit, + texpand, + thedit, + thistogram, + thselect, + tinfo, + tintegrate, + tjoin, + tlcol, + tlinear, + tmatch, + tmerge, + tprint, + tproduct, + tproject, + tquery, + tread, + trebin, + tselect, + tsort, + tstat, + ttranspose, + tunits, + tupar = "nttools$x_nttools.e" + + task gtpar = "nttools$gtpar.par" + + task txtable, + tximage, + titable, + tiimage, + tscopy = "nttools$threed/x_nttools.e" + + clbye() +end diff --git a/pkg/utilities/nttools/nttools.hd b/pkg/utilities/nttools/nttools.hd new file mode 100644 index 00000000..91010db4 --- /dev/null +++ b/pkg/utilities/nttools/nttools.hd @@ -0,0 +1,91 @@ +# Help directory for the TTOOLS package + +$doc = "pkg$utilities/nttools/doc/" +$tdoc = "pkg$utilities/nttools/threed/doc/" +$atools = "pkg$utilities/nttools/atools/" +$copyone = "pkg$utilities/nttools/copyone/" +$gtedit = "pkg$utilities/nttools/gtedit/" +$imtab = "pkg$utilities/nttools/imtab/" +$tcalc = "pkg$utilities/nttools/tcalc/" +$tchcol = "pkg$utilities/nttools/tchcol/" +$tcheck = "pkg$utilities/nttools/tcheck/" +$tchsize = "pkg$utilities/nttools/tchsize/" +$tcopy = "pkg$utilities/nttools/tcopy/" +$tcreate = "pkg$utilities/nttools/tcreate/" +$tdiffer = "pkg$utilities/nttools/tdiffer/" +$tedit = "pkg$utilities/nttools/tedit/" +$texpand = "pkg$utilities/nttools/texpand/" +$thedit = "pkg$utilities/nttools/thedit/" +$tinfo = "pkg$utilities/nttools/tinfo/" +$tintegrate = "pkg$utilities/nttools/tintegrate/" +$tjoin = "pkg$utilities/nttools/tjoin/" +$tlinear = "pkg$utilities/nttools/tlinear/" +$tmatch = "pkg$utilities/nttools/tmatch/" +$tmerge = "pkg$utilities/nttools/tmerge/" +$tprint = "pkg$utilities/nttools/tprint/" +$tproduct = "pkg$utilities/nttools/tproduct/" +$tproject = "pkg$utilities/nttools/tproject/" +$tquery = "pkg$utilities/nttools/tquery/" +$trebin = "pkg$utilities/nttools/trebin/" +$tselect = "pkg$utilities/nttools/tselect/" +$tsort = "pkg$utilities/nttools/tsort/" +$tstat = "pkg$utilities/nttools/tstat/" +$ttranspose = "pkg$utilities/nttools/ttranspose/" +$tupar = "pkg$utilities/nttools/tupar/" +$tunits = "pkg$utilities/nttools/tunits/" +$threed = "pkg$utilities/nttools/threed/" + +taextract hlp=doc$taextract.hlp, src=atools$taextract.x +tainsert hlp=doc$tainsert.hlp, src=atools$tainsert.x +gtedit hlp=doc$gtedit.hlp, src=gtedit$t_gtedit.x +gtpar hlp=doc$gtpar.hlp, src=ttools$gtpar.par +imtab hlp=doc$imtab.hlp, src=imtab$imtab.x +tabim hlp=doc$tabim.hlp, src=imtab$tabim.x +keypar hlp=doc$keypar.hlp, src=copyone$keypar.x +keytab hlp=doc$keytab.hlp, src=copyone$keytab.x +parkey hlp=doc$parkey.hlp, src=copyone$parkey.x +partab hlp=doc$partab.hlp, src=copyone$partab.x +tabkey hlp=doc$tabkey.hlp, src=copyone$tabkey.x +tabpar hlp=doc$tabpar.hlp, src=copyone$tabpar.x +tcalc hlp=doc$tcalc.hlp, src=tcalc$tcalc.x +tchcol hlp=doc$tchcol.hlp, src=tchcol$tchcol.x +tcheck hlp=doc$tcheck.hlp, src=tcheck$tcheck.x +tchsize hlp=doc$tchsize.hlp, src=tchsize$tchsize.x +tcopy hlp=doc$tcopy.hlp, src=tcopy$tcopy.x +tcreate hlp=doc$tcreate.hlp, src=tcreate$tcreate.x +tdelete hlp=doc$tdelete.hlp, src=tcopy$tdelete.x +tdiffer hlp=doc$tdiffer.hlp, src=tdiffer$tdiffer.x +tdump hlp=doc$tdump.hlp, src=tprint$tdump.x +tedit hlp=doc$tedit.hlp, src=tedit$tedit.x +texpand hlp=doc$texpand.hlp, src=texpand$texpand.x +thedit hlp=doc$thedit.hlp, src=thedit$t_thedit.x +thistogram hlp=doc$thistogram.hlp, src=tstat$thistogram.x +thselect hlp=doc$thselect.hlp, src=thedit$t_thselect.x +tinfo hlp=doc$tinfo.hlp, src=tinfo$tinfo.x +tintegrate hlp=doc$tintegrate.hlp, src=tintegrate$tintegrate.x +tjoin hlp=doc$tjoin.hlp, src=tjoin$tjoin.x +tlcol hlp=doc$tlcol.hlp, src=tinfo$tlcol.x +tlinear hlp=doc$tlinear.hlp, src=tlinear$tlinear.x +tmatch hlp=doc$tmatch.hlp, src=tmatch$tmatch.x +tmerge hlp=doc$tmerge.hlp, src=tmerge$tmerge.x +tprint hlp=doc$tprint.hlp, src=tprint$tprint.x +tproduct hlp=doc$tproduct.hlp, src=tproduct$tproduct.x +tproject hlp=doc$tproject.hlp, src=tproject$tproject.x +tquery hlp=doc$tquery.hlp, src=tquery$tquery.x +tread hlp=doc$tread.hlp, src=tedit$tread.x +trebin hlp=doc$trebin.hlp, src=trebin$trebin.x +tselect hlp=doc$tselect.hlp, src=tselect$tselect.x +tsort hlp=doc$tsort.hlp, src=tsort$tsort.x +tstat hlp=doc$tstat.hlp, src=tstat$tstat.x +ttranspose hlp=doc$ttranspose.hlp, src=ttranspose$ttranspose.x +tupar hlp=doc$tupar.hlp, src=tupar$tupar.x +tunits hlp=doc$tunits.hlp, src=tunits$tunits.x + +text_tables hlp="pkg$utilities/nttools/text_tables.hlp" + +txtable hlp=tdoc$txtable.hlp, src=threed$txtable.x +tximage hlp=tdoc$tximage.hlp, src=threed$tximage.x +titable hlp=tdoc$titable.hlp, src=threed$titable.x +tiimage hlp=tdoc$tiimage.hlp, src=threed$tiimage.x +tscopy hlp=tdoc$tscopy.hlp, src=threed$tcopy.x +selectors hlp=tdoc$selectors.hlp diff --git a/pkg/utilities/nttools/nttools.hlp b/pkg/utilities/nttools/nttools.hlp new file mode 100644 index 00000000..e02ffbd4 --- /dev/null +++ b/pkg/utilities/nttools/nttools.hlp @@ -0,0 +1,244 @@ +.help ttools May2000 tables +.nj + +This package contains tasks for working with tables. +Tables are files that contain data in row & column format. +The supported table formats are FITS, STSDAS, and ASCII text. +Different columns may have different data types, +but all the values in one column have the same data type. +In addition to the tabular data, +a table may contain header parameters identified by keywords. + +.nf +Each column has the following four items of information: + (1) a name (case insensitive), + (2) data type (real, double, integer, short int, boolean, or text), + (3) a format specification for printing the contents of the column, + (4) "units", a string (default is null). +.fi + +For STSDAS tables the column names and units +can be up to 20 characters in length. +For FITS tables the limit is 68 characters. +The default column names for ASCII tables are "c1", "c2", "c3", etc.; +however, there is a "#c" syntax for giving explicit column definitions, +which is described below. + +Header parameters may have data types of +floating point, integer, boolean, or text. +Header keywords are limited to eight characters (for FITS compatibility) +and are converted to upper case. + +The print formats are discussed below. + +Here is a list of the ttools tasks organized by function: + +.nf + create a table: + tcreate, tedit + + display contents: + tprint, tread, tedit, tcheck, thedit, thselect, tupar, gtedit + + modify contents: + tedit, thedit, tupar, gtedit + + information about a table: + tinfo, tlcol + + database-like utilities: + tquery, tsort, tproject, tselect, tdiffer, tjoin, tmatch, + tmerge, tproduct, texpand + + statistics, etc: + thistogram, tlinear, trebin, tstat + + arithmetic: + tcalc, tunits, tintegrate + + convert between table or image header parameter, cl parameter, table datum: + keypar, keytab, parkey, partab, tabkey, tabpar + + convert columns of arrays to other formats: + txtable, tximage, titable, tiimage, taextract, tainsert + + change column definition or table size: + tchcol, tchsize + + miscellaneous: + tcopy, tdelete +.fi + +ASCII text tables can be simple files +(just data in row and column format), +or they can have header keywords and/or explicit column definitions. + +Header keywords and column definitions +in text tables have the following syntax: +.nf +#k keyword = value comment +#c column_name data_type print_format units +.fi + +The "#k " (or "#K ") must be the first three characters of the line, +and the space following "k" is required. +Header keywords can be added to any text table, +and they do not have to precede the data. +For a text string keyword, +quotes around the value are needed if there is a comment, +in order to distinguish value from comment. + +The "#c " (or "#C ") must be the first three characters of the line, +and the space following "c" is required. +All column definitions must precede the table data. +Aside from the "#c ", the syntax is the same as +the output from 'tlcol' or the 'tcreate.cdfile'. +Only the column name is required, +although in most cases you will also need to give the data type +(the default is d, double precision). +The print format is not used for reading the text file, +only for displaying it or printing it out if it was modified. +The file is read in free format, +with whitespace (blank or tab) separated columns. +Text string columns must be enclosed in quotes +if they contain embedded blanks. + +For more information about text tables, "page tables$doc/text_tables.doc". + +The print format is used by such tasks as 'tprint', 'tedit', and 'tread' +to determine how the column values are to be displayed. +Most of the ordinary Fortran formats are supported for tables. +Nonstandard formats should not be used for FITS tables +for reasons of portability. +The differences between the capabilities of Fortran formats +and SPP formats are discussed below. + +Here is a list of the default print format for each data type, +given in both SPP style and Fortran style. + +.nf +default formats: + + data type SPP Fortran + --------- --- ------- + real %15.7g G15.7 + double prec %25.16g G25.16 + integer %11d I11 + short %11d I11 + boolean %6b L6 + text string %-ns A-n +.fi + +where n for character strings is the string size as given when the +column was defined. +The minus sign means that the string will be left justified. +While a format such as "A-12" is not available in standard Fortran, +a format may be given with that syntax when using ttools tasks, +and the format will be converted to SPP style. + +SPP formats (and Fortran equivalents) that are supported +for STSDAS tables are as follows. + +.nf + SPP Fortran meaning + --- ------- ------- + b L boolean "yes" or "no" + d I integer, displayed in decimal + x Z integer, displayed in hexadecimal + e E or D exponential format + f F floating point + g G use F or E as appropriate + h H nn:nn:nn.n + H (none) divide by 15, then nn:nn:nn.n + m M nn:nn.n + M (none) divide by 15, then nn:nn.n + s A character string +.fi + +The syntax is "%w.dC" (SPP style) or "Cw.d" (Fortran style), +where w is the field width, +d is the number of decimal places (or precision for g format), +and C is the format code as given in the left column below. +When giving a format in Fortran style, +use the format code given in the second column; +these are shown in upper case but may also be given in lower case. +Note that H and M are not standard Fortran formats; +in particular, H is not interpreted as Hollerith. +See below for more information about H and M formats. + +The field width (w) may be given as a positive number, +a negative number, or preceded by a zero. +A negative field width means the value should be left justified in the field. +A leading zero means the field should be padded on the left by zeroes; +for example, "%04d" or "I04" is equivalent to the standard Fortran "I4.4". +The d value means the number of decimal places +for f, h, m, H or M format, +but it means the digits of precision for g format. +For character strings, "%s" means left justify and +use only as much space as needed to print the value; +"%40s" and "%-40s" mean right and justify respectively in a 40-character field. + +When the format is given in SPP style, +there are two relatively new formats that are not available in Fortran. +Specifying upper case H or M means that +the numbers will be divided by 15 before being formatted +using h or m format respectively. +This is intended for converting hours to degrees. +When two table columns contain right ascension and declination, +both in decimal degrees, +then appropriate formats might be, +for example, %12.2H or %9.2M for right ascension +and %12.1h for declination. +This would print the right ascension in hours, minutes, seconds +(or hours and minutes for M format) with two decimals, +and would print the declination in degrees, minutes, seconds +with one decimal after the seconds. + +Here are some examples. + +.nf + internal value format displayed value + -------------- ------ --------------- + 2.71828 %10.4g 2.718 + 2.71828e27 %10.4g 2.718E27 + 2.71828 %10.4f 2.7183 + 2.71828 %10.4e 2.718E0 + 2.71828 %10.1h 2:43:05.8 + 2.71828 %10.1m 2:43.1 + 2.71828 %07.1m 02:43.1 + 2.71828 %10d 2 + 927 %10d 927 + 927 %-10d 927 + 927 %010d 0000000927 + ttools %s ttools + ttools %10s ttools + ttools %-10s ttools +.fi + +FITS and STSDAS tables can have columns that contain arrays ("3-D tables"). +That is, each cell (designated by both a column name and a row number) +stores a 1-dimensional array of elements instead of a single value. + +There are four tasks that act as 3-D table translators. These tasks extract +information from or insert information into "3-D tables". + +The information moved from/to a 3-D table by the tasks in this package can +have either of two forms, regular 2-D tables or 1-dimensional images. +Tasks 'txtable' and 'titable' perform, respectively, extractions and +insertions of 2-D tables. Tasks 'tximage' and 'tiimage' perform, respectively, +extractions and insertions of images. + +Task 'tscopy' is a variant of the 'tcopy' task. +It performs a standard table copy +but also supports the selector mechanism to allow copying of sections +of columns that contain arrays. +Type "help selectors" for further information about sections. + +.ih +SEE ALSO +.nf +selectors +files in tables$doc/ +.fi + +.endhelp diff --git a/pkg/utilities/nttools/nttools.men b/pkg/utilities/nttools/nttools.men new file mode 100644 index 00000000..53cd4fe9 --- /dev/null +++ b/pkg/utilities/nttools/nttools.men @@ -0,0 +1,61 @@ +Menu for the package tables.ttools + + keypar - Copy an image or table header keyword to an IRAF parameter. + keytab - Copy an image or table header keyword to a table element. + parkey - Put an IRAF parameter into an image or table header keyword. + partab - Transfer an IRAF parameter to a table element. + tabkey - Copy a table element to an image or table header keyword. + tabpar - Transfer a table element to an IRAF parameter. + + gtedit - Graphically edit a table. + gtpar - Pset to specify graph parameters for 'gtedit' task. + + imtab - Copy an image to a table column. + tabim - Copy a table column to an image. + + taextract - Copy an array entry to a column of scalars in another table. + tainsert - Copy a column of scalars to an array entry in another table. + + tcalc - Perform arithmetic operations on table columns. + tchcol - Change column name, print format, or units. + tcheck - Check STSDAS table element values. + tchsize - Change allocated sizes of various sections of a table. + tcopy - Copy tables. + tcreate - Create a STSDAS table from an ASCII descriptor table. + tdelete - Delete tables. + tdiffer - Form a table which is the difference of two tables. + tdump - Dump the contents of a table to an ASCII file. + tedit - Edit a table. + texpand - Expand tables according to a set of rules. + thedit - Edit or print table header keywords. + thistogram - Make a histogram of a column in a table. + thselect - Select tables satisfying an expression; print keywords. + tinfo - Display table size information. + tintegrate - Numerically integrate one column with respect to another. + tjoin - Perform a relational join of two tables. + tlcol - List column information for a table. + tlinear - Use linear regression to fit one or two table columns. + tmatch - Find closest match between rows in two tables + tmerge - Either merge or append tables. + tprint - Print tables--both headers and data. + tproduct - Form the Cartesian product of two tables. + tproject - Create new table from selected columns in a table. + tquery - Create a new table from selected rows and columns in a table. + tread - Browse through a table. + trebin - Resample a table to uniform spacing. + tselect - Create a new table from selected rows of a table. + tsort - Sort a table. + tstat - Get mean, standard deviation, min, and max for a column. + ttranspose - Transpose or flip a table. + tunits - Convert table column from one set of units to another + tupar - Edit table header keywords. + + 3-D table functions + tiimage - Insert images into rows of a 3-D table. + titable - Insert 2-D tables into rows of a 3-D table. + tximage - Extract images from rows of 3-D tables. + txtable - Extract 2-D tables from rows of 3-D tables. + tscopy - Copy row/column subsets of tables using selectors. + +Type "help selectors" for information about row and column selector syntax. + diff --git a/pkg/utilities/nttools/nttools.par b/pkg/utilities/nttools/nttools.par new file mode 100644 index 00000000..6a302939 --- /dev/null +++ b/pkg/utilities/nttools/nttools.par @@ -0,0 +1,3 @@ +# Dummy LOCAL package parameter file. + +version,s,h,"10May2000" diff --git a/pkg/utilities/nttools/parkey.par b/pkg/utilities/nttools/parkey.par new file mode 100644 index 00000000..35c138b4 --- /dev/null +++ b/pkg/utilities/nttools/parkey.par @@ -0,0 +1,5 @@ +value,s,a,"",,,"Value of header keyword" +output,f,a,"",,,"Name of file containing header keyword" +keyword,s,a,"",,,"Name of header keyword" +add,b,h,no,,,"Is it OK to create a new keyword?" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/partab.par b/pkg/utilities/nttools/partab.par new file mode 100644 index 00000000..b8860f99 --- /dev/null +++ b/pkg/utilities/nttools/partab.par @@ -0,0 +1,5 @@ +value,s,a,"",,,"Value of table element" +table,f,a,"",,,"Name of table" +column,s,a,"",,,"Name of column" +row,i,a,,,,"Number of row" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/stxtools/changt.x b/pkg/utilities/nttools/stxtools/changt.x new file mode 100644 index 00000000..c3d4e511 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/changt.x @@ -0,0 +1,98 @@ +#--------------------------------------------------------------------------- +.help change_ext Jun93 xtools +.ih +NAME +change_ext -- Put the specified extension on a file name. +.ih +USAGE +call change_ext (in_name, newext, out_name, max_size) +.ih +ARGUMENTS +.ls in_name (I: char[ARB]) +The input pathname with which to change the arguments. +.le +.ls newext (I: char[ARB]) +The extension to replace the original extension with. +.le +.ls out_name (O: char[max_size]) +The resultant pathname with the new extension inserted. May be the +same as the in_name. +.le +.ls max_size (I: int) +The maximum length of the string out_name. +.le +.ih +DESCRIPTION +This routine replaces the old extension on a pathname with the new +extension specified in the argument "newext". Thus: + +.nf + dir$root.ext --> dir$root.newext +.fi +.ih +SEE ALSO +fparse +.endhelp +#--------------------------------------------------------------------------- +procedure change_ext (in_name, newext, out_name, max_size) + +char in_name[ARB] # I: Original input name. +char newext[ARB] # I: Extension to replace old one. +char out_name[max_size] # O: File name with new extension. +int max_size # I: Maximum size out_name. + +# Misc. +pointer dir # Directory part of pathname. +int index # Group index in pathname. +pointer ksection # Unparsable part of pathname. +int ngroup # Number of groups. +pointer root # Root part of pathname. +pointer section # Section part of pathname. +pointer sp # Stack pointer. +pointer sx # Generic string. + +begin + call smark (sp) + call salloc (dir, SZ_LINE, TY_CHAR) + call salloc (root, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + call salloc (ksection, SZ_LINE, TY_CHAR) + call salloc (sx, SZ_LINE, TY_CHAR) + + # Parse the file name COMPLETELY. + call fparse (in_name, Memc[dir], SZ_LINE, Memc[root], SZ_LINE, + Memc[sx], SZ_LINE, index, ngroup, + Memc[section], SZ_LINE, Memc[ksection], SZ_LINE) + + # Put directory and root together. + call strcpy (Memc[dir], out_name, max_size) + call strcat (Memc[root], out_name, max_size) + + # Change the extension. + call strcat (".", out_name, max_size) + call strcat (newext, out_name, max_size) + + # Handle group syntax. + if (index > 0) { + call sprintf (Memc[sx], SZ_LINE, "[%d") + call pargi (index) + call strcat (Memc[sx], out_name, max_size) + if (ngroup > 0) { + call sprintf (Memc[sx], SZ_LINE, "/%d") + call pargi (ngroup) + call strcat (Memc[sx], out_name, max_size) + } + call strcat ("]", out_name, max_size) + } + + # Append the "unparsable" parts. + call strcat (Memc[ksection], out_name, max_size) + + # Finally image sections. + call strcat (Memc[section], out_name, max_size) + + call sfree (sp) +end +#--------------------------------------------------------------------------- +# End of change_ext +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/checkdim.x b/pkg/utilities/nttools/stxtools/checkdim.x new file mode 100644 index 00000000..ef9ed017 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/checkdim.x @@ -0,0 +1,24 @@ +include + +#* HISTORY* +#* B.Simon 04-Mar-93 original + +# CHECKDIM -- Get the real dimension of an image + +int procedure checkdim (im) + +pointer im # i: image descriptor +#-- +int idim, jdim + +begin + # Ignore higher dimesions that only have length one + + jdim = 1 + do idim = 1, IM_NDIM(im) { + if (IM_LEN(im,idim) > 1) + jdim = idim + } + + return (jdim) +end diff --git a/pkg/utilities/nttools/stxtools/cif.h b/pkg/utilities/nttools/stxtools/cif.h new file mode 100644 index 00000000..55d87ab5 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/cif.h @@ -0,0 +1,95 @@ +#--------------------------------------------------------------------------- +.help cif.h Apr94 source +.ih +NAME +cif.h -- Definitions for the Coordinated Input File object. +.endhelp +#--------------------------------------------------------------------------- +#==== +# Below are the PUBLIC definitions of the CIF object. These may be +# used by any external application as desired. +#==== + +# Generic size of file names/character strings used by CIF. +define CIF_SZ_FNAME SZ_PATHNAME + +# Possible values for the operation code passed to the 'cif_next' routine. +define CIF_NEXT_GROUP 1 # Get next, if any groups +define CIF_NEXT_FILE 2 # Get next primary file + +# Status of the secondary files after a 'cif_next" call. +define CIF_OK 1 # New file which is accessable. +define CIF_NONE 2 # No accessable file found. +define CIF_SAME 3 # File name is the same as previous. +define CIF_EXISTS 4 # Output file exists. + +# CIF structure variables: Primary file +define CIF_p_file_list CIF_file_list(CIF_p($1)) +define CIF_p_file CIF_file(CIF_p($1)) +define CIF_p_ext CIF_ext(CIF_p($1)) +define CIF_p_status CIF_status(CIF_p($1)) +define CIF_p_nloop CIF_nloop(CIF_p($1)) + +# CIF structure variables: Input Files +define CIF_in_file_list CIF_file_list(CIF_in($1,$2)) +define CIF_in_file CIF_file(CIF_in($1,$2)) +define CIF_in_ext CIF_ext(CIF_in($1,$2)) +define CIF_in_status CIF_status(CIF_in($1,$2)) +define CIF_in_nloop CIF_nloop(CIF_in($1,$2)) + +# CIF structure variables: Output Files. +define CIF_out_file_list CIF_file_list(CIF_out($1,$2)) +define CIF_out_file CIF_file(CIF_out($1,$2)) +define CIF_out_ext CIF_ext(CIF_out($1,$2)) +define CIF_out_status CIF_status(CIF_out($1,$2)) + +#=========================================================================== +#=========================================================================== +# The Private definitions to be used by the object code alone. Any use +# of the below macros constitutes an interface violation. +#=========================================================================== + +# Type of file which the current file name represents. +define CIF_GENERIC 1 +define CIF_IMAGE 2 +define CIF_DIRECTORY 3 +define CIF_SAME_ROOT 4 + +#==== +# The CIF object structure. +#==== +define CIF_p Memi[$1] +define CIF_in_ptr Memi[$1+1] +define CIF_n_in Memi[$1+2] +define CIF_out_ptr Memi[$1+3] +define CIF_n_out Memi[$1+4] +define CIF_loop Memi[$1+5] +define CIF_SZ 6 + +define CIF_in Memi[CIF_in_ptr($1)+$2-1] +define CIF_out Memi[CIF_out_ptr($1)+$2-1] + +#==== +# CIF File Object Structure +#==== +define CIF_list Memi[$1] +define CIF_group Memi[$1+1] +define CIF_status Memi[$1+2] +define CIF_nloop Memi[$1+3] +define CIF_cg Memi[$1+5] +define CIF_type Memi[$1+6] +define CIF_cbuf Memi[$1+7] +define CIF_SZ_FILE 8 + +define CIF_file_list Memc[CIF_cbuf($1)] +define CIF_file Memc[CIF_cbuf($1)+CIF_SZ_FNAME+1] +define CIF_ext Memc[CIF_cbuf($1)+2*(CIF_SZ_FNAME+1)] +define CIF_base Memc[CIF_cbuf($1)+3*(CIF_SZ_FNAME+1)] +define CIF_SZ_FILE_CBUF 4*(CIF_SZ_FNAME+1) + +# Indexed versions of some strings. +define CIF_basei Memc[CIF_CBUF($1)+3*(CIF_SZ_FNAME+1)+$2-1] + +#--------------------------------------------------------------------------- +# End of cif.h +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/cif.x b/pkg/utilities/nttools/stxtools/cif.x new file mode 100644 index 00000000..6fa3a7f2 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/cif.x @@ -0,0 +1,806 @@ +include +include "cif.h" + +#--------------------------------------------------------------------------- +.help cif Apr94 source +.ih +NAME +cif -- Coordinated Input File object +.ih +DESCRIPTION +The Coordinated Input File (CIF) object manages multiple input/output +files that are keyed on a single input file list. This is useful for +tasks whose input data may come from several different types of input +files. These input files are coordinated, or linked with, some +primary input file. This object also handles the creation of output +files, again linked in some way with the primary input file list. + +An explanation of the problem for which this interface was developed +should help demonstrate the point of the CIF object. For GHRS, the +calibrated output products includes a flux file, indicated by a file +extension of C1H, and a wavelength vector file, indicated by a file +extension of C0H. The number of groups in each file is the same, with +each group of the wavelength file corresponding to each group of the +flux file. The primary input file list would be the flux files and +the one of the secondary input files would be the rootname of the flux +file but with the C0H extension. The CIF object ensures that the +files are opened "in lock step". As output, there probably is only +one output list, each file with the same number of groups as the +primary input file, but with a new extension, some addition to the +rootname, or placed in another directory with the same root/extension. + +The following sections discuss the public and private +interfaces. +.ih +PUBLIC INTERFACE +The public interface to CIF consists of three subroutines and a number +of variables. The subroutines are: + +.nf + cif_alloc + cif_next + cif_free +.fi + +Detailed description of the subroutines are: + +.ls pointer = cif_alloc (n_in, n_out) +This routine creates the CIF object. It requires the number of input +files and output files that will be coordinated with the primary input +file. Note, the primary input file is NOT counted as one of the +inputs. The CIF variables are initialized to default or undefined +values. +.ls n_in (int) +Number of input files that will be coordinated. 0 if no input files +are required. +.le +.ls n_out (int) +Number of output files that will be coordinated. 0 if no output files +are requierd. +.le +.ls RETURNS (pointer) +Pointer to the CIF object. This pointer will be used in other +subroutine calls and accessing the CIF object variables. +.le +.le +.ls boolean = cif_next (o, type) +This is the main loop call for the CIF object. The CIF variables are +populated with the next set of file names. This can either be the +next groups of files, or a new set of files depending on the type +specified. If the value of cif_next is TRUE, then there are more +files. If FALSE, the end of the list has been reached, i.e. there are +no more primary files to be had. On return, the CIF variables *_file +and *_status are set. See the description below of the CIF +variables for more information. +.ls o (pointer) +The pointer to a CIF object created with cif_alloc. +.le +.ls type (int) +What "type" to get next. Possible values are +.nf + CIF_FILE - Get next primary file and associated + in/out files. + CIF_GROUP - Get next group +.fi +.le +.ls RETURNS (bool) +TRUE if there is another set of file names available. FALSE if no +more primary files are found. +.le +.le +.ls cif_free (o) +Deallocates the CIF object. +.ls o (pointer) +The pointer to the CIF object to destroy. Value will be NULL on +return. +.le +.le + +The CIF variables can be found in the include file 'cif.h' under the +public definition section. Below is the current list followed by a +detailed explanation. + +.nf + # CIF structure variables: Primary file + CIF_p_file_list(o) + CIF_p_file(o) + CIF_p_ext(o) + CIF_p_status(o) + CIF_p_nloop(o) + + # CIF structure variables: Input Files + CIF_in_file_list(o,i) + CIF_in_file(o,i) + CIF_in_ext(o,i) + CIF_in_status(o,i) + CIF_in_nloop(o,i) + + # CIF structure variables: Output Files. + CIF_out_file_list(o,i) + CIF_out_file(o,i) + CIF_out_ext(o,i) + CIF_out_status(o,i) +.fi + +For all of the above variables, 'o' is the pointer to the CIF object +and 'i' is the particular input/output file list to access, since +there can be multiple input/output files. The definition of each +variable is as follows: +.ls CIF_p_file_list, CIF_in_file_list, CIF_out_file_list (char[CIF_SZ_FNAME]) +These variables contain the initial file lists for the primary, input, +and output files. The lists can contain wildcards, substitution, and +"@file" specifications. Anything that is consistent with the IRAF +'imtopen' IMIO call. These variables have to be set after the call to +'cif_alloc' but before calling 'cif_next'. + +The output list is used a bit differently from the input lists. If +the next file name from an output list is a directory, the output file +name will be the same as the current primary file, but with this +directory. If the output list is empty, and the last name retrieved +from the output list is not a directory, then the output filename will +be the same as the current primary file, depending on the value of +CIF_out_ext, see below. If the output list is empty and the last file +from the output list was a directory, that directory will be used for +all subsequent primary files. +.le +.ls CIF_p_ext, CIF_in_ext, CIF_out_ext (char[CIF_SZ_FNAME]) +These variables contain the default file name extension to use for +each file. The default extensions do not have to be specified, i.e. +the value of these variables is an empty string. In that case, the +actions described below for each variable does not occur. The +symantics of the _EXT variable is slightly different for each type of +file: +.ls CIF_p_ext +If the next primary file, as retrieved from the primary file list, +does not exist, replace the original extension with this extension. +If the file still does not exist, the call to cif_next will error. +.le +.ls CIF_in_ext +This variable is used in two different ways. If the input file list +is empty, then this extension is placed on the current primary file +and the file is looked for. If the input list is not empty but the +next input file does not exist, this extension replaces the original +extension and existance is checked again. +.le +.ls CIF_out_ext +If specified, this extension is always placed on the output file name. +.le +.le +.ls CIF_p_nloop, CIF_in_nloop (int) +These variable specify how many calls to 'cif_next' must occur before +the next group/file is retrieved from the particular primary or input +list. The default value is 1, or every time 'cif_next' is called, +retrieve the next group/file. This is useful when a single group in +either the primary or input file corresponds to a number of groups in +another input file (or primary file). + +The output files don't have a counter, since the output file names are +created based on the primary file. +.le +.ls CIF_p_file, CIF_in_file, CIF_out_file (char[CIF_SZ_FNAME]) +On return from 'cif_next', these variables contain the next set of +file names. The validity of the name contained in each variable is +determined by the corresponding *_STATUS variable, see below. If any +of the files are images, a group specification is appended. +.le +.ls CIF_p_status, CIF_in_status, CIF_out_status (int) +The status or validity of the names contained in the *_FILE variables +after a call to 'cif_next'. The possible values are: +.ls CIF_OK +The name represents another file, different from the name returned by +a previous call to 'cif_next'. For the primary and input files, the +file exists. For output files, the file does not exist. +.le +.ls CIF_NONE +For input files, there is no more files in that particular input list. +The value of CIF_in_file is invalid, i.e. contains "garbage". The +primary file and output files will never have this status value. This +is because, when there are no more primary files, 'cif_next' returns +FALSE and the output files are created based on the primary files. +.le +.ls CIF_SAME +For primary and input values, this value indicates that the file name +is the same as that returned from a previous call to 'cif_next'. A +file name will not change only because the value of *_NLOOP and the +current call to 'cif_next' implied to not change the file name. + +For output files, this status indicates that the output file name is +the same as the current primary file. This can occur if the output +file list is empty and either no default extension was specified, or +the default extension happens to be the same as the current primary +file. Note, this indicates that the character string of the output +file matches the character string of the current primary file. There +is no check whether the created files would actually be the same. +For example, if the current primary file is "root.ext", and the output +file is "./root.ext", the status would be CIF_OK, not CIF_SAME. See +CIF_EXISTS. +.le +.ls CIF_EXISTS +For output files only, this indicates that the file exists. +.le +.le +The one constant in use is CIF_SZ_FNAME, size of all character +variables used by CIF. +.ih +PRIVATE INTERFACE +Note: There won't be much discussion here. Remember: "Use the force, +read the source". + +The CIF object consists of two structures. The CIF file object, which +maintains the individual files, and the CIF structure which +manages the number of files. + +.ls Subroutines +The subroutines are as follows: +.ls pointer = cif_alloc_file_obj() +Create the CIF file object. This contains the information specific to +an individual file list. +.ls RETURNS (pointer) +Returns a pointer to a CIF FILE object. +.le +.le +.ls cif_free_file_obj (o) +Destroy a CIF FILE object. +.ls o (pointer) +The FILE object to destroy. On return, the value will be NULL. +.le +.le +.ls bool = cif_next_primary (o) +Get the next primary file and all input/output files. Besides the +routines in the public interface, this is the only one that deals with +the CIF structure. This routine, regardless of the group counts and +whether there are any groups left, retrieve the next files from the +primary, input, and output lists and populates the CIF public +variables appropriately. +.ls o (pointer) +A pointer to the CIF object. +.le +.ls RETURNS (boolean) +TRUE if there is another set of files. FALSE if there are no more +primary files. +.le +.le +.ls cif_base2name (o, p) +Get the next file name for the specified FILE object, using +information from the primary FILE object. +.ls o (pointer) +The FILE object to get the next name for. This should only be a +primary FILE object or an input FILE object. Output FILE objects use +'cif_out'. +.le +.ls p (pointer) +The FILE object for the primary file list. +.le +.le +.ls int = cif_file_type (fname) +Determine the type of file specified. If the file does not exist, the +routine generates an error. +.ls fname (char[ARB]) +The name of the file to determine the type of. +.le +.ls RETURNS (int) +A file type id. See 'cif.h' under the Private definitions for a list +of file types. +.le +.le +.ls bool = cif_next_group (o, loop) +Get the file name representing the next group of the specified file. +.ls o +The primary or input FILE object to get the next group of. +.le +.ls loop (int) +The number of times 'cif_next' has been called. Used to decide +whether another group should be returned or not. +.le +.ls RETURNS (bool) +TRUE if there is another group, even if the group has not changed. +FALSE if there are no more groups in the current image. +.le +.le +.ls cif_out (o, p) +Find the next output file name based on the primary file. +.ls o (pointer) +The output FILE object to get the name for. +.le +.ls p (pointer) +The primary FILE object. +.le +.le +.le +.endhelp +#--------------------------------------------------------------------------- +pointer procedure cif_alloc (n_in, n_out) + +int n_in # I: Number of secondary input files. +int n_out # I: Number of output files. + +# Declarations. +pointer cif_alloc_file_obj() # Alloce a CIF FILE object. +pointer o # The CIF object. +int i # Generic. + +errchk cif_alloc_file_obj, malloc + +begin + # Allocate the CIF object. + call malloc (o, CIF_SZ, TY_STRUCT) + + # Allocate the CIF FILE object for the primary file. + CIF_p(o) = cif_alloc_file_obj() + + # Allocate FILE objects for each input file. + CIF_n_in(o) = n_in + call malloc (CIF_in_ptr(o), CIF_n_in(o), TY_POINTER) + do i = 1, CIF_n_in(o) { + CIF_in(o,i) = cif_alloc_file_obj () + } + + # Allocate FILE objects for each output file. + CIF_n_out(o) = n_out + call malloc (CIF_out_ptr(o), CIF_n_out(o), TY_POINTER) + do i = 1, CIF_n_out(o) { + CIF_out(o,i) = cif_alloc_file_obj () + } + + # Initialize the loop count + CIF_loop(o) = 0 + + # That's all folks. + return (o) +end +#--------------------------------------------------------------------------- +# End of cif_alloc +#--------------------------------------------------------------------------- +procedure cif_free (o) + +pointer o # IO: CIF object, NULL on return. + +# Declarations. +int i # generic. + +errchk cif_free_file_obj, mfree + +begin + # Free FILE objects for each output file. + do i = 1, CIF_n_out(o) + call cif_free_file_obj (CIF_out(o,i)) + call mfree (CIF_out_ptr(o), TY_POINTER) + + # Free FILE objects for each input file. + do i = 1, CIF_n_in(o) + call cif_free_file_obj (CIF_in(o,i)) + call mfree (CIF_in_ptr(o), TY_POINTER) + + # Free the primary FILE object. + call cif_free_file_obj (CIF_p(o)) + + # Remove the object. + call mfree (o, TY_STRUCT) +end +#--------------------------------------------------------------------------- +# End of cif_free +#--------------------------------------------------------------------------- +pointer procedure cif_alloc_file_obj () + +# Declarations. +pointer o # The CIF FILE object. + +errchk malloc + +begin + # Get memory. + call malloc (o, CIF_SZ_FILE, TY_STRUCT) + call malloc (CIF_cbuf(o), CIF_SZ_FILE_CBUF, TY_CHAR) + + # Setup initial values. + call strcpy ("", CIF_file_list(o), CIF_SZ_FNAME) + call strcpy ("", CIF_file(o), CIF_SZ_FNAME) + CIF_list(o) = NULL + CIF_group(o) = NULL + call strcpy ("", CIF_ext(o), CIF_SZ_FNAME) + CIF_status(o) = CIF_NONE + CIF_nloop(o) = 1 + CIF_cg(o) = INDEFI + call strcpy ("", CIF_base(o), CIF_SZ_FNAME) + CIF_type(o) = INDEFI + + # That's all folks. + return (o) +end +#--------------------------------------------------------------------------- +# End of cif_alloc_file_obj +#--------------------------------------------------------------------------- +procedure cif_free_file_obj (o) + +pointer o # IO: CIF FILE object, NULL on return. + +# Declarations. +errchk imtclose, mfree, tp_close + +begin + # Close other opened objects. + if (CIF_list(o) != NULL) + call imtclose (CIF_list(o)) + if (CIF_group(o) != NULL) + call tp_close (CIF_group(o)) + + # That's all folks. + call mfree (CIF_cbuf(o), TY_CHAR) + call mfree (o, TY_STRUCT) +end +#--------------------------------------------------------------------------- +# End of cif_free_file_obj +#--------------------------------------------------------------------------- +bool procedure cif_next (o, type) + +pointer o # I: The CIF object. +int type # I: Get a group or file. + +# Declarations +bool another # True if another set of files are available. +bool bx # Generic. +bool cif_next_group() # Get next group. +bool cif_next_primary() # Get next primary files. +int i # Generic. +int imtlen() # Length of a file list. +pointer imtopen() # Open an file list. + +errchk imtlen, imtopen + +begin + # Increment the loop count. + CIF_loop(o) = CIF_loop(o) + 1 + + # If the lists have not been opened, do it now. + if (CIF_list(CIF_p(o)) == NULL) { + CIF_list(CIF_p(o)) = imtopen (CIF_file_list(CIF_p(o))) + if (imtlen (CIF_list(CIF_p(O))) <= 0) + call error (1, "cif: no input files specified") + do i = 1, CIF_n_in(o) + CIF_list(CIF_in(o,i)) = imtopen (CIF_file_list(CIF_in(o,i))) + do i = 1, CIF_n_out(o) + CIF_list(CIF_out(o,i)) = imtopen (CIF_file_list(CIF_out(o,i))) + another = cif_next_primary (o) + } + + # Else, if type is FILE, just get next set of files. + else if (type == CIF_NEXT_FILE) + another = cif_next_primary (o) + + # Else, loop through groups. + else { + if (cif_next_group (CIF_p(o), CIF_loop(o))) { + + # Loop through all the inputs. + do i = 1, CIF_n_in(o) + bx = cif_next_group (CIF_in(o,i), CIF_loop(o)) + + # Loop through all the outputs. + do i = 1, CIF_n_out(o) + call cif_out (CIF_out(o,i), CIF_p(o)) + + # There is another file. + another = true + } + + # Else, get the next set of files. + else + another = cif_next_primary (o) + } + + # That's all folks. + return (another) +end +#--------------------------------------------------------------------------- +# End of cif_next +#--------------------------------------------------------------------------- +bool procedure cif_next_primary (o) + +pointer o # I: The CIF object. + +# Declarations. +bool another # True if another set of files is available. +int i # Generic. +int imtgetim() # Get next file from file list. +char sx[SZ_LINE] # Generic string. + +errchk imtgetim + +begin + # Open next primary image. If there are no more, then + # that's all. + if (imtgetim (CIF_list(CIF_p(o)), CIF_base(CIF_p(o)), + CIF_SZ_FNAME) != EOF) { + call cif_base2name (CIF_p(o), CIF_p(o)) + if (CIF_status(CIF_p(o)) == CIF_NONE) { + call sprintf (sx, SZ_LINE, "cif: no primary file %s") + call pargstr (CIF_base(CIF_p(o))) + call error (1, sx) + } + + # Open the next set of input files. + do i = 1,CIF_n_in(o) { + if (imtgetim (CIF_list(CIF_in(o,i)), CIF_base(CIF_in(o,i)), + CIF_SZ_FNAME) == EOF) + call strcpy ("", CIF_base(CIF_in(o,i)), CIF_SZ_FNAME) + call cif_base2name (CIF_in(o,i), CIF_p(o)) + } + + # Open the next set of output files. + do i = 1, CIF_n_out(o) { + CIF_status(CIF_out(o,i)) = CIF_OK + if (imtgetim (CIF_list(CIF_out(o,i)), CIF_base(CIF_out(o,i)), + CIF_SZ_FNAME) == EOF) { + if (IS_INDEFI(CIF_type(CIF_out(o,i)))) + CIF_type(o,i) = CIF_GENERIC + else + CIF_status(CIF_out(o,i)) = CIF_SAME + } + + call cif_out (CIF_out(o,i), CIF_p(o)) + } + + # Indicate that another set of files are available. + another = true + + } else + another = false + + # That's all folks. + return (another) +end +#--------------------------------------------------------------------------- +# End of cif_next_primary +#--------------------------------------------------------------------------- +procedure cif_base2name (o, p) + +pointer o # I: CIF FILE Object to find name for. +pointer p # I: CIF FILE Object of primary file. + +# Declarations +bool bx # Generic. +int cif_file_type() # Determine file type of file. +int i # Generic. +int strlen() # Get length of string. +bool tp_fetch() # Get next group. +pointer tp_open() # Open a group list. + +errchk tp_close, tp_fetch, tp_open + +begin + # If there is a group list open, close it. + if (CIF_group(o) != NULL) + call tp_close (CIF_group(o)) + + # Determine file type. If there is an error, try with + # the default extension. If that doesn't exist, try default + # extension of the primary name. + CIF_status(o) = CIF_OK + if (strlen(CIF_base(o)) <= 0) { + call change_ext (CIF_base(p), CIF_ext(o), CIF_file(o), + CIF_SZ_FNAME) + iferr (CIF_type(o) = cif_file_type (CIF_file(o))) + CIF_status(o) = CIF_NONE + } else { + call strcpy (CIF_base(o), CIF_file(o), CIF_SZ_FNAME) + iferr (CIF_type(o) = cif_file_type (CIF_file(o))) { + call change_ext (CIF_file(o), CIF_ext(o), CIF_file(o), + CIF_SZ_FNAME) + iferr (CIF_type(o) = cif_file_type (CIF_file(o))) + CIF_status(o) = CIF_NONE + } + } + + # Make the new name the base. + if (CIF_status(o) == CIF_OK) { + call strcpy (CIF_file(o), CIF_base(o), CIF_SZ_FNAME) + + # If the file is an image, open the group list. + if (CIF_type(o) == CIF_IMAGE) { + CIF_group(o) = tp_open (CIF_file(o), 0, i) + bx = tp_fetch (CIF_group(o), CIF_file(o)) + } + CIF_cg(o) = 1 + } +end +#--------------------------------------------------------------------------- +# End of cif_base2name +#--------------------------------------------------------------------------- +int procedure cif_file_type (fname) + +char fname[ARB] # I: The file to determine type of. + +# Declarations. +int access() # Get file access. +pointer immap() # Open an image. +pointer px # Generic. +int strlen() # Get length of string. +int type # Type of file. + +errchk access, imunmap + +begin + if (strlen (fname) <= 0) + call error (1, "cif: Unknown type") + else ifnoerr (px = immap (fname, READ_ONLY, NULL)) { + type = CIF_IMAGE + call imunmap (px) + } else if (access (fname, 0, 0) == YES) + type = CIF_GENERIC + else + call error (1, "cif: Unknown type") + + return (type) +end +#--------------------------------------------------------------------------- +# End of cif_file_type +#--------------------------------------------------------------------------- +bool procedure cif_next_group (o, loop) + +pointer o # I: The CIF FILE object. +int loop # I: Current loop count. + +# Declarations +bool tp_fetch() # Get next group. + +errchk tp_fetch + +begin + # Is this file a type to have groups? + if (CIF_type(o) == CIF_IMAGE) { + + # Is this loop one to change on? + if (mod (loop-1, CIF_nloop(o)) == 0) { + + # Get the next group. + if (tp_fetch (CIF_group(o), CIF_file(o))) { + CIF_status(o) = CIF_OK + CIF_cg(o) = CIF_cg(o) + 1 + } + + # Else, no more data. + else + CIF_status(o) = CIF_NONE + } + + # Nope, keep it the same. + else + CIF_status(o) = CIF_SAME + } + + # Else, nope, no groups here. + else + CIF_status(o) = CIF_NONE + + # Return true if a file exists. + return (CIF_status(o) != CIF_NONE) +end +#--------------------------------------------------------------------------- +# End of cif_next_group +#--------------------------------------------------------------------------- +procedure cif_out (o, p) + +pointer o # I: CIF FILE Object to get output name. +pointer p # I: Primary CIF FILE Object to get info. + +# Declarations +int access() # Is file accessable? +int cl_index, cl_size # Cluster info. +char dir[CIF_SZ_FNAME] # Directory of the file name. +char ext[CIF_SZ_FNAME] # Extension of the file name. +int i # Generic. +int isdirectory() # Is a file a directory? +char ksection[CIF_SZ_FNAME] # Ksection of the file name. +char root[CIF_SZ_FNAME] # Root of the file name. +char section[CIF_SZ_FNAME] # Section of the file name. +bool streq() # Are strings equal? +int strlen() # Get length of string. +char sx[1] # Generic. + +errchk access, fbuild, fparse, isdirectory + +begin + # If a new input, determine what it is. + if (CIF_status(o) != CIF_SAME) { + if (strlen (CIF_base(o)) <= 0) + CIF_type(o) = CIF_SAME_ROOT + else if (isdirectory (CIF_base(o), root, SZ_PATHNAME) > 0) + CIF_type(o) = CIF_DIRECTORY + else + CIF_type(o) = CIF_GENERIC + } + + # Create the new file name. + call fparse (CIF_file(p), dir, CIF_SZ_FNAME, root, CIF_SZ_FNAME, + ext, CIF_SZ_FNAME, cl_index, cl_size, section, + CIF_SZ_FNAME, ksection, CIF_SZ_FNAME) + switch (CIF_type(o)) { + case CIF_DIRECTORY: + call strcpy (CIF_base(o), dir, CIF_SZ_FNAME) + + case CIF_GENERIC: + call fparse (CIF_base(o), dir, CIF_SZ_FNAME, root, CIF_SZ_FNAME, + ext, CIF_SZ_FNAME, i, i, sx, 1, sx, 1) + } + + # If a different extension is supplied, use it. + if (strlen (CIF_ext(o)) > 0) { + call strcpy (".", ext, CIF_SZ_FNAME) + call strcat (CIF_ext(o), ext, CIF_SZ_FNAME) + } + + # Build the new file name. + call fbuild (dir, root, ext, cl_index, cl_size, section, ksection, + CIF_file(o), CIF_SZ_FNAME) + + # Set status if the name is the same as the primary file. + if (streq (CIF_file(p), CIF_file(o))) + CIF_status(o) = CIF_SAME + else { + if (access (CIF_file(o), 0, 0) == YES) + CIF_status(o) = CIF_EXISTS + else + CIF_status(o) = CIF_OK + } +end +#--------------------------------------------------------------------------- +# End of cif_out +#--------------------------------------------------------------------------- +procedure cif_test() + +pointer cif, cif_alloc() +bool cif_next() +int clgeti(), i + +begin + cif = cif_alloc (2, 1) + + call clgstr ("primary", CIF_p_file_list(cif), CIF_SZ_FNAME) + call clgstr ("p_ext", CIF_p_ext(cif), CIF_SZ_FNAME) + CIF_p_nloop(cif) = clgeti ("p_loop") + call clgstr ("in1", CIF_in_file_list(cif,1), CIF_SZ_FNAME) + call clgstr ("in1_ext", CIF_in_ext(cif,1), CIF_SZ_FNAME) + CIF_in_nloop(cif,1) = clgeti ("in1_loop") + call clgstr ("in2", CIF_in_file_list(cif,2), CIF_SZ_FNAME) + call clgstr ("in2_ext", CIF_in_ext(cif,2), CIF_SZ_FNAME) + CIF_in_nloop(cif,2) = clgeti ("in2_loop") + call clgstr ("out1", CIF_out_file_list(cif,1), CIF_SZ_FNAME) + call clgstr ("out1_ext", CIF_out_ext(cif,1), CIF_SZ_FNAME) + + while (cif_next (cif, CIF_NEXT_GROUP)) { + call printf ("Primary file == '%s'") + call pargstr (CIF_p_file(cif)) + if (CIF_p_status(cif) == CIF_SAME) + call printf (" (same as previous)") + call printf ("\n") + + do i = 1, 2 { + switch (CIF_in_status(cif,i)) { + case CIF_OK: + call printf (" Input %d is '%s'\n") + call pargi (i) + call pargstr (CIF_in_file(cif,i)) + case CIF_NONE: + call printf (" No files for input %d\n") + call pargi (i) + case CIF_SAME: + call printf (" Input %d is '%s' (same as previous)\n") + call pargi (i) + call pargstr (CIF_in_file(cif,i)) + } + } + + call printf (" Output file is '%s'") + call pargstr (CIF_out_file(cif,1)) + if (CIF_out_status(cif,1) == CIF_EXISTS) + call printf (" (file exists)") + else if (CIF_out_status(cif,1) == CIF_SAME) + call printf (" (same as input)") + call printf ("\n") + } + + call cif_free (cif) +end +#--------------------------------------------------------------------------- +# End of cif_test +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/clgnone.x b/pkg/utilities/nttools/stxtools/clgnone.x new file mode 100644 index 00000000..b6fde15c --- /dev/null +++ b/pkg/utilities/nttools/stxtools/clgnone.x @@ -0,0 +1,37 @@ +# CLGNONE -- Get a string parameter whose value may be "none" +# +# B.Simon 20-Jun-94 original +# B.Simon 30-Jan-95 moved to stxtools + +procedure clgnone (param, value, maxch) + +char param[ARB] # i: parameter name +char value[ARB] # o: parameter value +int maxch # i: maximum length of value +#-- +pointer sp, temp1, temp2 +bool streq() + +begin + # Allocate memory for temporary strings + + call smark (sp) + call salloc (temp1, maxch, TY_CHAR) + call salloc (temp2, maxch, TY_CHAR) + + # Read parameter and convert to lower case for simpler comparison + + call clgstr (param, Memc[temp1], maxch) + call strcpy (Memc[temp1], Memc[temp2], maxch) + call strjust (Memc[temp2]) + + # If value is none, set to null string + + if (Memc[temp2] == EOS || streq (Memc[temp2], "none")) { + value[1] = EOS + } else { + call strcpy (Memc[temp1], value, maxch) + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/stxtools/copyimg.x b/pkg/utilities/nttools/stxtools/copyimg.x new file mode 100644 index 00000000..0248cfa9 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/copyimg.x @@ -0,0 +1,78 @@ +include + +# COPYIMG -- Copy one image to another +# +# B.Simon 02-Mar-92 Original +# B.Simon 16-Mar-94 Delete fast copy, check for existing image + +procedure copyimg (old, new) + +char old[ARB] # i: old image +char new[ARB] # i: new image +#-- +int npix, junk +pointer buf1, buf2, im1, im2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] + +int imaccess() +int imgnls(), imgnll(), imgnlr(), imgnld(), imgnlx() +int impnls(), impnll(), impnlr(), impnld(), impnlx() +pointer immap() + +errchk immap, imunmap + +begin + # Map the input and output images + # Code adapted from iraf's imcopy task + + im1 = immap (old, READ_ONLY, 0) + if (imaccess (new, READ_WRITE) == NO) { + im2 = immap (new, NEW_COPY, im1) + } else { + im2 = immap (new, READ_WRITE, NULL) + } + + # 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) + +end diff --git a/pkg/utilities/nttools/stxtools/doc/wcs.doc b/pkg/utilities/nttools/stxtools/doc/wcs.doc new file mode 100644 index 00000000..8154a944 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/doc/wcs.doc @@ -0,0 +1,177 @@ +Routines for conversion between pixel coordinates and world coordinates. + + This package contains the following high-level routines for converting +between world coordinates and pixel coordinates: + +xt_wcs_init initialize structure for world coordinate system +xt_wcs_init_c initialize from input cdelt, crota, etc +xt_wcs_init_cd initialize from input CD matrix, etc +xt_wc_pix convert from world coordinates to pixel coordinates +xt_pix_wc convert from pixel coordinates to world coordinates +xt_wcs_free deallocate wcs struct + +After calling any one of the three initialization routines, either or both +of the conversion routines (xt_wc_pix, xt_pix_wc) may be called any number +of times. When finished, xt_wcs_free should be called to deallocate memory +that was allocated by the initialization routine. + + Eight different projection geometries are currently implemented for +spherical coordinates. The projection type is obtained from the CTYPE +parameter, or the type defaults to gnomonic if nothing is specified in +CTYPE. Here is a list of CTYPE values for the right ascension axis with +the various projection types. For Aitoff and Mercator projections the +reference pixel is assumed to be on the equator. In addition, for Aitoff +projection the difference between right ascension and RA at the reference +pixel is limited to 180 degrees. + + CTYPE projection type + ----- --------------- + RA---TAN gnomonic (tangent) + RA---SIN radial distance proportional to sine of angle + RA---ARC radial distance proportional to angle + RA---NCP north celestial pole + RA---GBS global sine (equal area) + RA---STG stereographic + RA---AIT Aitoff equal area + RA---MER Mercator + + + To use the following sample program, extract into a file "ttt.x" +and compile and link with: + + xc -p tables ttt.x -lstxtools + +task ttt + +include + +procedure ttt() + +pointer im, wcs +double phys[IM_MAXDIM] +real pix[IM_MAXDIM], opix[IM_MAXDIM] +int naxis, k +char input[SZ_FNAME] +pointer immap() +int scan() + +begin + call clgstr ("input", input, SZ_FNAME) + im = immap (input, READ_ONLY, NULL) + naxis = IM_NDIM(im) + call xt_wcs_init (im, wcs) # initialize + call imunmap (im) + + call printf ("naxis = %d\n") + call pargi (naxis) + call printf ("enter pixel coordinates\n") + + while (scan() != EOF) { + do k = 1, naxis + call gargr (pix[k]) + call xt_pix_wc (wcs, pix, phys, naxis) # to world coords + call xt_wc_pix (wcs, phys, opix, naxis) # to pixel coords + # Print the input pixel coordinates, the world coordinates, + # and the output pixel coordinates (which should be the same + # as the input). + do k = 1, naxis { + call printf ("%.3f %18.10g %.3f\n") + call pargr (pix[k]) + call pargd (phys[k]) + call pargr (opix[k]) + } + } + call xt_wcs_free (wcs) # free memory +end + + + +# xt_wcs_init -- initialize wcs struct +# This routine allocates space for a structure describing the world +# coordinate system for an image, fills in the values or defaults, and +# returns a pointer to that structure. + +call xt_wcs_init (im, wcs) + +pointer im # i: pointer to image descriptor +pointer wcs # o: pointer to world coord system struct + + +# xt_wcs_init_c -- initialize wcs struct +# xt_wcs_init_c and xt_wcs_init_cd allocate space for a structure +# describing the world coordinate system for an image, fill in the values +# or defaults, and return a pointer to that structure. They differ from +# xt_wcs_init in that these take the coordinate parameters as arguments +# rather than getting them from the image. +# xt_wcs_init_c takes cdelt & crota, and xt_wcs_init_cd takes the CD matrix. + +call xt_wcs_init_c (crval, crpix, cdelt, crota, ctype, naxis, wcs) + +double crval[naxis] # i: coordinate values at reference pixel +real crpix[naxis] # i: reference pixel +real cdelt[naxis] # i: pixel spacing +real crota # i: rotation angle (if 2-D) +char ctype[SZ_CTYPE,naxis] # i: e.g. "RA---TAN" +int naxis # i: size of arrays +pointer wcs # o: pointer to world coord system struct + + +call xt_wcs_init_cd (crval, crpix, cd, ctype, naxis, wcs) + +double crval[naxis] # i: coordinate values at reference pixel +real crpix[naxis] # i: reference pixel +real cd[naxis,naxis] # i: CD matrix +char ctype[SZ_CTYPE,naxis] # i: e.g. "RA---TAN" +int naxis # i: size of arrays +pointer wcs # o: pointer to world coord system struct + + +# xt_wcs_free -- deallocate wcs struct +# This routine deallocates space for a wcs structure. + +call xt_wcs_free (wcs) + +pointer wcs # io: pointer to world coord system struct + + + +# xt_wc_pix -- wcs to pixels +# This routine converts world coordinates to pixel coordinates. +# +# In the 1-D case, CRVAL is subtracted from the coordinate, the +# result is divided by CDELT (same as CD1_1), and CRPIX is added. +# +# For 2-D or higher dimension, if two of the axes are like RA and Dec, +# the input coordinates are converted to standard coordinates Xi +# and Eta. The (Xi, Eta) vector is then multiplied on the left by +# the inverse of the CD matrix, and CRPIX is added. +# The units for axes like Ra & Dec are degrees, not hours or radians. +# For linear axes the conversion is the same as for 1-D. + +call xt_wc_pix (wcs, phys, pix, naxis) + +pointer wcs # i: pointer to world coord system struct +double phys[naxis] # i: physical (world) coordinates (e.g. degrees) +real pix[naxis] # o: pixel coordinates +int naxis # i: size of arrays + + + +# xt_pix_wc -- pixels to wcs +# This routine converts pixel coordinates to world coordinates. +# +# In the 1-D case, CRPIX is subtracted from the pixel coordinate, +# the result is multiplied by CDELT (same as CD1_1), and CRVAL is added. +# +# For 2-D or higher dimension, CRPIX is subtracted, and the result is +# multiplied on the left by the CD matrix. If two of the axes are like +# RA and Dec, the pixel coordinates are converted to standard coordinates +# Xi and Eta. The (Xi, Eta) vector is then converted to differences +# between RA and Dec and CRVAL, and then CRVAL is added to each coordinate. + +call xt_pix_wc (wcs, pix, phys, naxis) + +pointer wcs # i: pointer to world coord system struct +real pix[naxis] # i: pixel coordinates +double phys[naxis] # o: physical (world) coordinates (e.g. degrees) +int naxis # i: size of arrays diff --git a/pkg/utilities/nttools/stxtools/errxit.x b/pkg/utilities/nttools/stxtools/errxit.x new file mode 100644 index 00000000..45b5a7a3 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/errxit.x @@ -0,0 +1,30 @@ +# ERRXIT -- Take an error exit and set the error code + +# This error exit routine is used on VMS system. The VMS symbol $status +# will be set to the exit_code, so that the process running this program +# will know the error condition that terminated the program. In order +# to avoid conflict with other VMS exit codes, it would be best if the +# exit_code is set to an odd value greater than one. +# +# Nelson Zarate 30-Nov-95 original +# Perry Greenfield 18-Apr-95 change exit code from 122 to 2 +# so that misleading DCL error message +# is not given (severity level remains +# the same: 2 --> ERROR). 122 results +# in a "DEVICE NOT MOUNTED" message. + +procedure errxit (exit_code) + +int exit_code +#-- + +begin + # Reset the exit code to a constant value for this routine that + # will be called on a VMS system. Other system will run the + # errxit.c that lives in tables$lib/stxtools/errxit.c to be inserted + # at compilation time by mkpkg.sf.. + # NZ Nov 30 1995 + exit_code = 2 + + call exit (exit_code) +end diff --git a/pkg/utilities/nttools/stxtools/fbuild.x b/pkg/utilities/nttools/stxtools/fbuild.x new file mode 100644 index 00000000..1dcf6448 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/fbuild.x @@ -0,0 +1,97 @@ +#--------------------------------------------------------------------------- +.help fbuild Nov93 source +.ih +NAME +fbuild -- Build a file name based on components. +.ih +USAGE +call fbuild (dir, root, ext, clindex, clsize, section, ksection, + file, sz_file) +.ih +ARGUMENTS +.ls dir (Input: char[ARB]) +The directory specification. This may be blank. If not, it should +include the directory separator, i.e. a '$' or '/' at the end of the +directory. +.le +.ls root (Input: char[ARB]) +The rootname specification. This may be left blank. No other +punctuation besides what goes into a rootname is required. +.le +.ls ext (Input: char[ARB]) +The file extension specification. This may be left blank. If +specified, the extension separater must be prepended, i.e. a period +'.' must be the first character. +.le +.ls clindex (Input: int) +The cl index or group number. If zero, it will not be placed into the +pathname. +.le +.ls clsize (Input: int) +The cl size (or maximum group) number. If zero, it will not be placed +into the pathname. +.le +.ls section (Input: char[ARB]) +The section specification. Must include the surrounding '[' and ']' +section separators. +.le +.ls ksection (Input: char[ARB]) +The ksection specification. Must include the surrounding '[' and ']' +ksection separators. +.le +.ls file (Output: char[sz_file]) +The output pathname. +.le +.ls sz_file (Input: int) +The maximum size of the output file specification. +.le +.ih +DESCRIPTION +fbuild builds a pathname based on individual components. This +complements the routine fparse. For example, if a full pathname +exists, a call to fparse followed by a call to fbuild should reproduce +the pathname. +.ih +REFERENCES +Jonathan Eisenhamer, STSDAS +.ih +SEE ALSO +fparse +.endhelp +#--------------------------------------------------------------------------- +procedure fbuild (dir, root, ext, clindex, clsize, section, ksection, + file, sz_file) + +char dir[ARB] # I: Directory specification. +char root[ARB] # I: Rootname specification. +char ext[ARB] # I: Extension specification. +int clindex # I: Index number. +int clsize # I: Size number. +char section[ARB] # I: Section specification. +char ksection[ARB] # I: KSection specification. +char file[sz_file] # O: File name. +int sz_file # I: Maximum size of the file name. + +char Index[SZ_PATHNAME] # The Group specification. + +begin + call strcpy (dir, file, sz_file) + call strcat (root, file, sz_file) + call strcat (ext, file, sz_file) + call strcpy ("", Index, SZ_PATHNAME) + if (clindex > 0) + if (clsize > 0) { + call sprintf (Index, SZ_PATHNAME, "[%d/%d]") + call pargi (clindex) + call pargi (clsize) + } else { + call sprintf (Index, SZ_PATHNAME, "[%d]") + call pargi (clindex) + } + call strcat (Index, file, sz_file) + call strcat (section, file, sz_file) + call strcat (ksection, file, sz_file) +end +#--------------------------------------------------------------------------- +# End of fbuild +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/fparse.x b/pkg/utilities/nttools/stxtools/fparse.x new file mode 100644 index 00000000..33dee6ff --- /dev/null +++ b/pkg/utilities/nttools/stxtools/fparse.x @@ -0,0 +1,170 @@ +#--------------------------------------------------------------------------- +.help fparse Aug98 xtools +.ih +NAME +fparse -- Parse a file name +.ih +USAGE +call fparse (input, dir, dir_size, root, root_size, ext, ext_size, + cl_index, cl_size, section, section_size, ksection, + ksection_size) +.ih +ARGUMENTS +.ls input (I: char[ARB]) +The input file name to parse into its components. +.le +.ls dir (O: char[dir_size]) +The directory component of the file name. Includes the directory +separator character. +.le +.ls dir_size (I: int) +The maximum length of the string to place in the dir argument. +.le +.ls root (O: char[root_size]) +The root component of the file name. Includes any wildcard characters +specified for the root. +.le +.ls root_size (I: int) +The maximum length of the string to place in the root argument. +.le +.ls ext (O: char[ext_size]) +The extension component of the file name. DOES NOT INCLUDE the +extension separator, i.e. the ".". +.le +.ls ext_size (I: int) +The maximum length of the string to place in the ext argument. +.le +.ls cl_index (O: int) +The cluster or group index found in the file name. If none is found, +this returns -1. Before IRAF v2.11, returned 0. +.le +.ls cl_size (O: int) +The number of clusters or groups found in the file name. If none is +found, this returns -1. Before IRAF v2.11, returned 0. +.le +.ls section (O: char[section_size]) +The image section specification part of the file name. Will contain +the standard image section specifications. +.le +.ls section_size (I: int) +The maximum length of the string to place in the section argument. +.le +.ls ksection (O: char[ksection_size]) +This is the "catchall". If the filename cannot be parsed into the +form "dir$root.ext[cl_index/cl_size][section]", ksection will contain +the extra. +.le +.ih +DESCRIPTION +This routine basically performs the individual functions of fnldir, +fnext, and fnroot, and the "illegal" imparse. The only distinct +advantage to this routine is that wildcard characters, and the +relative directory characters ".", and ".." can be present in the file +name. +.ih +BUGS +This routine calls the illegal routine imparse. If the image naming +conventions in IMIO ever change, this routine will surely break all to +pieces. +.endhelp +#--------------------------------------------------------------------------- +# +# M.D. De La Pena - 11 August 1998: updated internal documentation for +# cl_index and cl_size to reflect changes made for IRAF v2.11. +# +procedure fparse (input, dir, dir_size, root, root_size, ext, ext_size, + cl_index, cl_size, section, section_size, ksection, + ksection_size) + +char input[ARB] # I: Input pathname +char dir[dir_size] # O: Directory part of pathname. +int dir_size # I: Max size of dir. +char root[root_size] # O: Root part of pathname. +int root_size # I: Max size of root. +char ext[ext_size] # O: Extension part of pathname. +int ext_size # I: Max size of extension. +int cl_index # O: The cluster index. +int cl_size # O: The cluster size. +char section[section_size] # O: The section part of pathname. +int section_size # I: Max size of section. +char ksection[ksection_size] # O: The remainder of the pathname. +int ksection_size # I: Max size of ksection. + +# Declarations +int i # Generic. +int len_dir # Length of the directory spec. + +pointer cluster # Cluster. +pointer last_period # Pointer to the last period. +pointer new_cluster # Cluster without the directory spec. +pointer ptr # Pointer into strings. +pointer sp # Stack pointer. + +string wildcards "*?" + +# Function prototypes. +int fnldir(), stridxs() +bool streq() + +begin + + call smark(sp) + call salloc (cluster, SZ_LINE, TY_CHAR) + + # Parse the name with the (illegal) call imparse. + call imparse (input, Memc[cluster], SZ_LINE, ksection, + ksection_size, section, section_size, cl_index, + cl_size) + + # Further parse the the cluster name into directory, root, + # and extension. + # Wildcards are a problem. The above only deals with fully qualified + # pathnames, not templates. But, it seems it could be done. Scan + # the directory for wildcards and try to parse out a bit more. The + # assumption made is that directories cannot be wildcarded. + root[1] = EOS + ext[1] = EOS + len_dir = fnldir (Memc[cluster], dir, dir_size) + i = stridxs (wildcards, dir) + if (i > 0) { + dir[i] = EOS + len_dir = fnldir (dir, dir, dir_size) + } + + # Now there is just root and extension. Check to see if root is just + # the relative directory names. If so, append them to the directory + # specification. + new_cluster = cluster + len_dir + if (streq (Memc[new_cluster], ".") || streq (Memc[new_cluster], "..")) { + call strcat (Memc[new_cluster], dir, dir_size) + call strcat ("/", dir, dir_size) + } + + # Else, find the extension. This is just the last found "." in the + # specification. + else { + last_period = NULL + ptr = new_cluster + while (Memc[ptr] != EOS) { + if ( Memc[ptr] == '.') + last_period = ptr + ptr = ptr + 1 + } + if (last_period == NULL) { + call strcpy (Memc[new_cluster], root, root_size) + ext[1] = EOS + } else { + Memc[last_period] = EOS + call strcpy (Memc[new_cluster], root, root_size ) + Memc[last_period] = '.' + call strcpy (Memc[last_period], ext, ext_size) + } + } + + # That's all folks. + call sfree(sp) + +end +#--------------------------------------------------------------------------- +# End of fparse +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/grmimy.x b/pkg/utilities/nttools/stxtools/grmimy.x new file mode 100644 index 00000000..bd30f93e --- /dev/null +++ b/pkg/utilities/nttools/stxtools/grmimy.x @@ -0,0 +1,68 @@ +include + +#--------------------------------------------------------------------------- +.help grm_imcopy Oct92 source +.ih +NAME +grm_imcopy -- Copy images given their image descriptors. +.endhelp +#--------------------------------------------------------------------------- +procedure grm_imcopy (in, out) + +pointer in # I: Input image descriptor of image to copy. +pointer out # I: Output image descriptor of resultant image. + +# Declarations. +long v1[IM_MAXDIM], v2[IM_MAXDIM] # Line and section counters. + +int junk # Generic. +int npix # Length of a line of data. + +pointer buf1, buf2 # Data buffers. + +# Function Prototypes. +int imgnls(), imgnll(), imgnlr(), imgnld(), imgnlx() +int impnls(), impnll(), impnlr(), impnld(), impnlx() + +begin + + # 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(in, 1) + switch (IM_PIXTYPE(in)) { + case TY_SHORT: + while (imgnls (in, buf1, v1) != EOF) { + junk = impnls (out, buf2, v2) + call amovs (Mems[buf1], Mems[buf2], npix) + } + case TY_USHORT, TY_INT, TY_LONG: + while (imgnll (in, buf1, v1) != EOF) { + junk = impnll (out, buf2, v2) + call amovl (Meml[buf1], Meml[buf2], npix) + } + case TY_REAL: + while (imgnlr (in, buf1, v1) != EOF) { + junk = impnlr (out, buf2, v2) + call amovr (Memr[buf1], Memr[buf2], npix) + } + case TY_DOUBLE: + while (imgnld (in, buf1, v1) != EOF) { + junk = impnld (out, buf2, v2) + call amovd (Memd[buf1], Memd[buf2], npix) + } + case TY_COMPLEX: + while (imgnlx (in, buf1, v1) != EOF) { + junk = impnlx (out, buf2, v2) + call amovx (Memx[buf1], Memx[buf2], npix) + } + default: + call error (1, "unknown pixel datatype") + } + +end +#--------------------------------------------------------------------------- +# End of grm_imcopy +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/isblank.x b/pkg/utilities/nttools/stxtools/isblank.x new file mode 100644 index 00000000..85edb9d7 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/isblank.x @@ -0,0 +1,18 @@ +include + +# ISBLANK -- Return true if the string is entirely white space +# +# B.Simon 11-Nov-87 First Code + +bool procedure isblank (str) + +char str[ARB] # i: string to be tested +int ip + +begin + do ip = 1, ARB + if (str[ip] == EOS) + return (true) + else if (! IS_WHITE(str[ip]) ) + return (false) +end diff --git a/pkg/utilities/nttools/stxtools/lubksb.f b/pkg/utilities/nttools/stxtools/lubksb.f new file mode 100644 index 00000000..429cf2e4 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/lubksb.f @@ -0,0 +1,50 @@ + SUBROUTINE LUBKSB (A, N, NP, INDX, B) + +C Solves a matrix equation AX = B. Before using this routine you must +C call ludcmp to decompose the matrix A (in-place) into lower and upper +C triangular portions. The vector B is input to this routine, and the +C answer X is returned in B. +C +C real a(np,np) i: matrix returned by ludcmp +C int n i: logical size of a is n x n +C int np i: space allocated for a is np x np +C int indx(n) i: index returned by ludcmp +C real b(n) io: input b, output x in equation ax = b +C +C 1988 Oct 28 From Numerical Recipes + + INTEGER N, NP + REAL A(NP,NP) + INTEGER INDX(N) + REAL B(N) + + REAL SUM + INTEGER II, LL, I, J + + II = 0 + DO 20 I = 1, N + LL = INDX(I) + SUM = B(LL) + B(LL) = B(I) + IF (II .NE. 0) THEN + DO 10 J = II, I-1 + SUM = SUM - A(I,J) * B(J) + 10 CONTINUE + ELSE IF (SUM .NE. 0.) THEN + II = I + ENDIF + B(I) = SUM + 20 CONTINUE + + DO 40 I = N, 1, -1 + SUM = B(I) + IF (I .LT. N) THEN + DO 30 J = I+1, N + SUM = SUM - A(I,J) * B(J) + 30 CONTINUE + ENDIF + B(I) = SUM / A(I,I) + 40 CONTINUE + + RETURN + END diff --git a/pkg/utilities/nttools/stxtools/lubksd.f b/pkg/utilities/nttools/stxtools/lubksd.f new file mode 100644 index 00000000..04e17c6c --- /dev/null +++ b/pkg/utilities/nttools/stxtools/lubksd.f @@ -0,0 +1,53 @@ + SUBROUTINE LUBKSD (A, N, NP, INDX, B) + +C Double-precision version of LUBKSB. +C +C Solves a matrix equation AX = B. Before using this routine you must +C call ludcmd to decompose the matrix A (in-place) into lower and upper +C triangular portions. The vector B is input to this routine, and the +C answer X is returned in B. +C +C double a(np,np) i: matrix returned by ludcmp +C int n i: logical size of a is n x n +C int np i: space allocated for a is np x np +C int indx(n) i: index returned by ludcmp +C double b(n) io: input b, output x in equation ax = b +C +C 1988 Oct 28 From Numerical Recipes. +C 1992 Sep 10 Rename from LUBKSB and convert to double precision. + + INTEGER N, NP + DOUBLE PRECISION A(NP,NP) + INTEGER INDX(N) + DOUBLE PRECISION B(N) + + DOUBLE PRECISION SUM + INTEGER II, LL, I, J + + II = 0 + DO 20 I = 1, N + LL = INDX(I) + SUM = B(LL) + B(LL) = B(I) + IF (II .NE. 0) THEN + DO 10 J = II, I-1 + SUM = SUM - A(I,J) * B(J) + 10 CONTINUE + ELSE IF (SUM .NE. 0.) THEN + II = I + ENDIF + B(I) = SUM + 20 CONTINUE + + DO 40 I = N, 1, -1 + SUM = B(I) + IF (I .LT. N) THEN + DO 30 J = I+1, N + SUM = SUM - A(I,J) * B(J) + 30 CONTINUE + ENDIF + B(I) = SUM / A(I,I) + 40 CONTINUE + + RETURN + END diff --git a/pkg/utilities/nttools/stxtools/ludcmd.x b/pkg/utilities/nttools/stxtools/ludcmd.x new file mode 100644 index 00000000..708a9df9 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/ludcmd.x @@ -0,0 +1,99 @@ +define TINY 1.d-20 + +# ludcmd -- lower-upper decomposition +# Double-precision version of ludcmp from Numerical Recipes. +# This differs from the Numerical Recipes version in the following ways: +# (1) the calling sequence also includes an ISTAT parameter, (2) memory +# is allocated instead of using the fixed array VV, and (3) double +# precision is used. +# This routine decomposes a matrix (in-place) into lower and upper +# triangular portions. Use lubksd to obtain a solution to A * X = B +# or to compute the inverse of the matrix A. +# If the matrix is singular, ISTAT is set to one. +# +# Phil Hodge, 28-Oct-1988 Subroutine copied from Numerical Recipes. +# Phil Hodge, 10-Sep-1992 Convert to double precision and rename from ludcmp. + +procedure ludcmd (a, n, np, indx, d, istat) + +double a[np,np] # io: input a, output decomposed a +int n # i: logical size of a is n x n +int np # i: space allocated for a +int indx[n] # o: index to be used by xt_lubksb +double d # o: +1 or -1 +int istat # o: OK if no problem; 1 if matrix is singular +#-- +pointer sp +pointer vv # scratch space +double aamax +double sum +double dum +int i, j, k +int imax + +begin + istat = OK # initial value + + call smark (sp) + call salloc (vv, n, TY_DOUBLE) + + d = 1.d0 + do i = 1, n { + aamax = 0.d0 + do j = 1, n + if (abs(a[i,j]) > aamax) + aamax = abs(a[i,j]) + if (aamax == 0.d0) { + istat = 1 + return + } + Memd[vv+i-1] = 1.d0 / aamax + } + do j = 1, n { + if (j > 1) { + do i = 1, j-1 { + sum = a[i,j] + if (i > 1) { + do k = 1, i-1 + sum = sum - a[i,k] * a[k,j] + a[i,j] = sum + } + } + } + aamax = 0.d0 + do i = j, n { + sum = a[i,j] + if (j > 1) { + do k = 1, j-1 + sum = sum - a[i,k] * a[k,j] + a[i,j] = sum + } + dum = Memd[vv+i-1] * abs[sum] + if (dum >= aamax) { + imax = i + aamax = dum + } + } + if (j != imax) { + do k = 1, n { + dum = a[imax,k] + a[imax,k] = a[j,k] + a[j,k] = dum + } + d = -d + Memd[vv+imax-1] = Memd[vv+j-1] + } + indx[j] = imax + if (j != n) { + if (a[j,j] == 0.d0) + a[j,j] = TINY + dum = 1.d0 / a[j,j] + do i = j+1, n + a[i,j] = a[i,j] * dum + } + } + if (a[n,n] == 0.d0) + a[n,n] = TINY + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/stxtools/ludcmp.x b/pkg/utilities/nttools/stxtools/ludcmp.x new file mode 100644 index 00000000..cb2ce43d --- /dev/null +++ b/pkg/utilities/nttools/stxtools/ludcmp.x @@ -0,0 +1,87 @@ +define TINY 1.e-20 + +# ludcmp -- lower-upper decomposition +# This routine decomposes a matrix (in-place) into lower and upper +# triangular portions. This is the same as the Numerical Recipes version +# except that memory is allocated instead of using the fixed array VV. +# +# Phil Hodge, 28-Oct-1988 Subroutine copied from Numerical Recipes. + +procedure ludcmp (a, n, np, indx, d) + +real a[np,np] # io: input a, output decomposed a +int n # i: logical size of a is n x n +int np # i: space allocated for a +int indx[n] # o: index to be used by xt_lubksb +real d # o: +1 or -1 +#-- +pointer sp +pointer vv # scratch space +real aamax +real sum +real dum +int i, j, k +int imax + +begin + call smark (sp) + call salloc (vv, n, TY_REAL) + + d = 1. + do i = 1, n { + aamax = 0. + do j = 1, n + if (abs(a[i,j]) > aamax) + aamax = abs(a[i,j]) + if (aamax == 0.) + call error (0, "singular matrix") + Memr[vv+i-1] = 1. / aamax + } + do j = 1, n { + if (j > 1) { + do i = 1, j-1 { + sum = a[i,j] + if (i > 1) { + do k = 1, i-1 + sum = sum - a[i,k] * a[k,j] + a[i,j] = sum + } + } + } + aamax = 0. + do i = j, n { + sum = a[i,j] + if (j > 1) { + do k = 1, j-1 + sum = sum - a[i,k] * a[k,j] + a[i,j] = sum + } + dum = Memr[vv+i-1] * abs[sum] + if (dum >= aamax) { + imax = i + aamax = dum + } + } + if (j != imax) { + do k = 1, n { + dum = a[imax,k] + a[imax,k] = a[j,k] + a[j,k] = dum + } + d = -d + Memr[vv+imax-1] = Memr[vv+j-1] + } + indx[j] = imax + if (j != n) { + if (a[j,j] == 0.) + a[j,j] = TINY + dum = 1. / a[j,j] + do i = j+1, n + a[i,j] = a[i,j] * dum + } + } + if (a[n,n] == 0.) + a[n,n] = TINY + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/stxtools/mkpkg b/pkg/utilities/nttools/stxtools/mkpkg new file mode 100644 index 00000000..218ad5f5 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/mkpkg @@ -0,0 +1,54 @@ +# Update the xtools library. +# Author: Phil Hodge, 16-NOV-1988 +# Modified to include similar.x : B.Simon 14-Mar-1989 +# Modified to include group template expansion routines : B.Simon 14-Feb-1990 +# Modified to include word.x and vex*.x : B.Simon 21-May-1990 +# Modified to include copyimg.x: B.Simon 02-Mar-1992 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + + +libpkg.a: + @od + @sp_util + @wcslab + changt.x + checkdim.x + cif.x "cif.h" + clgnone.x + copyimg.x + errxit.x + fbuild.x + fparse.x + grmimy.x + isblank.x + lubksb.f + lubksd.f + ludcmd.x + ludcmp.x + postexit.x + savgol.x + sbuf.x "sbuf.h" + sgcone.x + similar.x + strjust.x + stxgetcoord.x + tpbreak.x + tpclose.x "template.h" + tpcount.x "template.h" + tpfetch.x "template.h" + tpgroup.x + tpimtype.x "template.h" + tpopen.x "template.h" + tpparse.x + vexcompile.x "vex.h" "vex.com" + vexeval.x "vex.h" + vexfree.x "vex.h" + vexfunc.x "vex.h" + vexstack.x "vex.h" + word.x + xtwcs.x + ; diff --git a/pkg/utilities/nttools/stxtools/od/mkpkg b/pkg/utilities/nttools/stxtools/od/mkpkg new file mode 100644 index 00000000..a72fbad9 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/mkpkg @@ -0,0 +1,15 @@ +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + odget.x "od.h" + odmap.x "od.h" + odopep.x "od.h" + odpare.x + odput.x "od.h" + odsetn.x "od.h" + odunmp.x "od.h" + odwcsn.x "od.h" + ; diff --git a/pkg/utilities/nttools/stxtools/od/od.h b/pkg/utilities/nttools/stxtools/od/od.h new file mode 100644 index 00000000..2070d551 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/od.h @@ -0,0 +1,32 @@ +#--------------------------------------------------------------------------- +.help od.h Feb93 source +.ih +NAME +od.h -- Include parameters for the 1D I/O data system. +.endhelp +#--------------------------------------------------------------------------- +#----- +# Below describes the structure and access to the OD descriptor. +define OD_FD Memi[$1] # The image/table descriptor +define OD_TYPE Memi[$1+1] # TABLE/IMAGE flag. +define OD_CD_PTR Memi[$1+2] # Table column descriptor. +define OD_CD Memi[OD_CD_PTR($1)+$2-1] +define OD_LEN Memi[$1+3] # Dimension of the data. +define OD_NGRP Memi[$1+4] # Number of groups in image. +define OD_GRP Memi[$1+5] # Current open group. +define OD_NAME_PTR Memi[$1+6] # Specified file name. +define OD_NAME Memc[OD_NAME_PTR($1)] +define OD_MW Memi[$1+7] # MWCS descriptor. +define OD_WL Memi[$1+8] # World-to-Logical transformation. +define OD_LW Memi[$1+9] # Logical-to-World transformation. +define OD_WSYS_PTR Memi[$1+10] # WCS system type. +define OD_WSYS Memc[OD_WSYS_PTR($1)] +define OD_OLD Memi[$1+11] # Template which opened this OD. +define OD_SZ_OD 12 # Size of structure. + +# The flag of what type of file we are dealing with. +define OD_TABLE 1 +define OD_IMAGE 2 +#--------------------------------------------------------------------------- +# End of od.h +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/od/odget.x b/pkg/utilities/nttools/stxtools/od/odget.x new file mode 100644 index 00000000..013acc67 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/odget.x @@ -0,0 +1,56 @@ +include "od.h" + +#--------------------------------------------------------------------------- +.help od_get Feb93 source +.ih +NAME +od_get -- Retrieve data from file. +.ih +USAGE +.nf +call od_getd (od, data) +.fi +.ih +ARGUMENTS +.ls od (pointer :input) +The OD I/O descriptor. +.le +.ls data (double[ARB] :output) +The data from the OD file. +.le +.endhelp +#--------------------------------------------------------------------------- +procedure od_get (od, data) + +pointer od # I: The OD I/O descriptor. +double data[ARB] # O: The data. + +pointer null # Null flag array for table IO. + +# Functions +pointer imgl1d() + +errchk gf_opengr, imgl1d, malloc, mfree, tbcgtd + +begin + # Check if a file is actually opened. If not, do nothing. + if (od != NULL) { + + # Get data depending on file type. + switch (OD_TYPE(od)) { + case OD_TABLE: + call malloc (null, OD_LEN(od), TY_BOOL) + call tbcgtd (OD_FD(od), OD_CD(od,OD_GRP(od)), data, Memb[null], + 1, OD_LEN(od)) + call mfree (null, TY_BOOL) + + case OD_IMAGE: + + # Retrieve the data. + call amovd (Memd[imgl1d(OD_FD(od))], data, OD_LEN(od)) + } + } +end +#--------------------------------------------------------------------------- +# End of od_get +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/od/odmap.x b/pkg/utilities/nttools/stxtools/od/odmap.x new file mode 100644 index 00000000..f41ad5e1 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/odmap.x @@ -0,0 +1,250 @@ +include +include +include +include +include "od.h" + +# Define the default column number to retrieve table data from +define DEFAULT_COL 1 + +#--------------------------------------------------------------------------- +.help od_map Feb93 source +.ih +NAME +.nf +od_map -- Open a file as either an image or table. + +od_image_map -- Internal: Map an image. +od_table_map -- Internal: Map a table. +.fi +.ih +USAGE +.nf +od = od_map (name, mode, old) + +call od_image_map (name, od) +call od_table_map (name, mode, od) +.fi +.ih +ARGUMENTS +.ls name (char[ARB] :input) +The name of the file to open. +.le +.ls mode (int :input) +The access mode to open the file in. Same as the standard IRAF open +modes. +.le +.ls old (pointer :input) +If creating a new file, use this as a template. If NULL, no template will +be assumed. This is the OD descriptor, not an IMIO or TABLE descriptor. +.le +.ls od (pointer :input) +The OD I/O descriptor. +.le +.ih +RETURNS +An od i/o file descriptor containing the image/table descriptor, a flag +indicating whether it is an image or table, and, if a table, the column +descriptor to retrieve the data from. +.ih +DESCRIPTION +This provides a common interface to retrieve one dimensional data from +either an image or a table. This is vary basic and is not intended to +handle a full i/o interface. Just need to open, close, and read data. + +Added some syntax to the table name specification. We will allow the +column names/numbers to be specified in a "section" notation. An +example: + +.nf + tablename[columnname1,...] +.fi + +where columnnameX are either names or numbers. If no column +specification is used, then it is assumed all columns of the table are +to be used and will be considered with the appropriate "group" of +multigroup input. +.endhelp +#--------------------------------------------------------------------------- +pointer procedure od_map(name, mode, old) + +char name[ARB] # I: The file name to open. +int mode # I: The mode to open the file in. +pointer old # I: Template OD I/O descriptor as template. + +# Declarations. +pointer od # OD I/O descriptor. +pointer sp # Stack Pointer. +pointer sx # Generic string. + +# Function prototypes +pointer immap() + +errchk malloc, od_image_map, od_table_map + +begin + call smark (sp) + call salloc (sx, SZ_LINE, TY_CHAR) + + # Allocate the od i/o descriptor. + call malloc (od, OD_SZ_OD, TY_STRUCT) + call malloc (OD_NAME_PTR(od), SZ_LINE, TY_CHAR) + call malloc (OD_WSYS_PTR(od), SZ_LINE, TY_CHAR) + + # If an old descriptor is given, base what open occurs on + # its type. + OD_OLD(od) = old + if (old != NULL) + switch (OD_TYPE(old)) { + case OD_IMAGE: + OD_FD(od) = immap (name, mode, OD_FD(old)) + call od_image_map (name, od) + case OD_TABLE: + call od_table_map (name, mode, OD_FD(old), od) + } + + # Else, just open up that data file. If the image call doesn't fail, + # then assume its an image. + else ifnoerr (OD_FD(od) = immap (name, mode, NULL)) + call od_image_map (name, od) + + # If it cannot be opened as a table, try changing the extension. + # If that fails, then give it up. + else iferr (call od_table_map (name, mode, NULL, od)) { + call change_ext (name, "c1h", Memc[sx], SZ_LINE) + iferr (OD_FD(od) = immap (Memc[sx], mode, NULL)) { + call erract (EA_ERROR) + } + call od_image_map (Memc[sx], od) + } + + # That's all folks. + call sfree (sp) + return (od) +end +#--------------------------------------------------------------------------- +# End of od_map +#--------------------------------------------------------------------------- +procedure od_image_map (name, od) + +char name[ARB] # I: Full specified name. +pointer od # I: OD I/O descriptor. + +# Declarations. +int i # Generic. + +pointer sp # Stack pointer. +pointer sx + +begin + call smark (sp) + call salloc (sx, SZ_LINE, TY_CHAR) + + # Fill the OD I/O descriptor. + OD_TYPE(od) = OD_IMAGE + OD_CD_PTR(od) = NULL + OD_LEN(od) = IM_LEN(OD_FD(od),1) + OD_NGRP(od) = max(1,IM_CLSIZE(OD_FD(od))) + call strcpy (IM_HDRFILE(OD_FD(od)), OD_NAME(od), SZ_LINE) + + # See whether a specific group was opened. + call fparse (name, Memc[sx], SZ_LINE, Memc[sx], SZ_LINE, Memc[sx], + SZ_LINE, OD_GRP(od), i, Memc[sx], SZ_LINE, Memc[sx], + SZ_LINE) + if (OD_GRP(od) > 0) + OD_NGRP(od) = 1 + else + OD_GRP(od) = 1 + + # Get world coordinate information. + call od_wcs_open (od) + + # That's all folks. + call sfree (sp) +end +#--------------------------------------------------------------------------- +# End of od_image_map +#--------------------------------------------------------------------------- +procedure od_table_map (name, mode, old, od) + +char name[ARB] # I: The specified file name. +int mode # I: The file access mode. +pointer old # I: Original OD descriptor. +pointer od # I: The OD I/O descriptor. + +# Declarations. +int i, j, k # Generic. +int ic # Pointer into section list. + +pointer colname # Current column name. +pointer section # Section specification. +pointer sp # Stack pointer. +pointer sx # Generic. + +# Functions. +int ctoi(), strlen(), word_count(), word_fetch(), tbpsta() +pointer tbcnum(), tbtopn() + +errchk tbcnum, tbpsta, tbtopn, word_count, word_fetch + +begin + call smark (sp) + call salloc (colname, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + call salloc (sx, SZ_LINE, TY_CHAR) + + # Set what type of file. + OD_TYPE(od) = OD_TABLE + + # Get the base filename and section. + call od_parse (name, OD_NAME(od), SZ_LINE, Memc[section], SZ_LINE) + + # Open up and get some parameters. + OD_FD(od) = tbtopn (OD_NAME(od), mode, old) + OD_LEN(od) = tbpsta (OD_FD(od), TBL_NROWS) + OD_GRP(od) = 1 + OD_MW(od) = NULL + OD_WL(od) = NULL + OD_LW(od) = NULL + + # Now retrieve the columns. If no columns are specified, then use + # all the columns. + if (strlen (Memc[section]) <= 0) { + OD_NGRP(od) = tbpsta (OD_FD(od), TBL_NCOLS) + call malloc (OD_CD_PTR(od), OD_NGRP(od), TY_POINTER) + do i = 1, OD_NGRP(od) { + OD_CD(od,i) = tbcnum (OD_FD(od), i) + if (OD_CD(od,i) == NULL) { + call sprintf (Memc[sx], SZ_LINE, "Cannot open column %d in table %s") + call pargi (i) + call pargstr (OD_NAME(od)) + call error (1, Memc[sx]) + } + } + } else { + OD_NGRP(od) = word_count (Memc[section]) + call malloc (OD_CD_PTR(od), OD_NGRP(od), TY_POINTER) + i = 0 + ic = 1 + while (word_fetch (Memc[section], ic, Memc[colname], SZ_LINE) > 0) { + i = i + 1 + k = 1 + if (ctoi (Memc[colname], k, j) > 0) + OD_CD(od,i) = tbcnum (OD_FD(od), j) + else + call tbcfnd (OD_FD(od), Memc[colname], OD_CD(od,i), 1) + } + if (OD_CD(od,i) == NULL) { + call sprintf (Memc[sx], SZ_LINE, "Cannot open column %s in table %s") + call pargstr (Memc[colname]) + call pargstr (OD_NAME(od)) + call error (1, Memc[sx]) + } + } + + # That's all folks. + call sfree (sp) +end +#--------------------------------------------------------------------------- +# End of od_table_map +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/od/odopep.x b/pkg/utilities/nttools/stxtools/od/odopep.x new file mode 100644 index 00000000..cd757f93 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/odopep.x @@ -0,0 +1,56 @@ +include "od.h" + +#--------------------------------------------------------------------------- +.help od_open_group 11Jul95 source +.ih +NAME +od_open_group -- Open another "group" of the file +.ih +USAGE +call od_open_group (od, group) +.fi +.ih +ARGUMENTS +.ls od (pointer :input) +The OD I/O descriptor. +.le +.ls group (int :input) +The "group" to open. For tables, this means the column number to open. +.le +.endhelp +#--------------------------------------------------------------------------- +procedure od_open_group (od, group) + +pointer od # I: The 1D descriptor. +int group # I: The group to open. + +# Misc. +real rx # Generic. + +errchk gf_opengr, mw_close, od_wcs_open + +begin + switch (OD_TYPE(od)) { + case OD_TABLE: + if (group > OD_NGRP(od)) + call error (1, "Attempt to open non-existant column") + OD_GRP(od) = group + + case OD_IMAGE: + if (group > OD_NGRP(od)) + call error (1, "Attempt to open non-existant group") + + call mw_close (OD_MW(od)) + + if (OD_OLD(od) != NULL) + call gf_opengr (OD_FD(od), group, rx, rx, OD_FD(OD_OLD(od))) + else + call gf_opengr (OD_FD(od), group, rx, rx, NULL) + OD_GRP(od) = group + + call od_wcs_open (od) + } +end +#--------------------------------------------------------------------------- +# End of od_open_group +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/od/odpare.x b/pkg/utilities/nttools/stxtools/od/odpare.x new file mode 100644 index 00000000..0bea6112 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/odpare.x @@ -0,0 +1,84 @@ +#--------------------------------------------------------------------------- +.help od_parse Feb93 source +.ih +NAME +od_parse -- Parse a section for column names. +.ih +USAGE +call od_parse +.ih +ARGUMENTS +.ih +DESCRIPTION +Taken from Bernie Simon's aspare without any modifications. +.endhelp +#--------------------------------------------------------------------------- +#* HISTORY * +#* D.Ball 18-Apr-88 original +#* B.Simon 06-Aug-92 removed code which deletes commas + +# OD_PARSE -- Parse a file name specification into file name and section fields +# +# Syntax: filename[section] +# +# The [ character must be escaped to be included in the filename. +# This syntax is similar to the image section syntax in imio, but +# is intended to extract variable names or numbers, column names, etc. +# for the Astronomical Survival analysis suite of programs. +# The section field is returned as a string with no leading or trailing +# brackets. + +procedure od_parse (filespec, file, sz_file, section, sz_section) + +char filespec[ARB] # i: full file specification +char file[sz_file] # o: receives file name +int sz_file # i: max chars in file name +char section[sz_section] # o: receives section +int sz_section # i: max chars in section name +#-- +int ch, ip, op, right + +int strlen() + +begin + ip = 1 + op = 1 + + # Extract file name. The first (unescaped) [ marks the start of + # the section field. + + for (ch=filespec[ip]; ch != EOS && ch != '['; ch=filespec[ip]) { + if (ch == '\\' && filespec[ip+1] == '[') { + file[op] = '\\' + op = op + 1 + file[op] = '[' + ip = ip + 1 + } else + file[op] = ch + + op = min (sz_file, op + 1) + ip = ip + 1 + } + + file[op] = EOS + section[1] = EOS + + if (ch == EOS) + return + + # If we have a [...] field, copy the section string, + # removing the brackets, and any commas used as delimiters. + + # Eliminate the leading "[" + ip = ip + 1 + call strcpy (filespec[ip], section, sz_section) + + # Remove the trailing "]" + right = strlen (section) + if (section[right] == ']') + section[right] = EOS + +end +#--------------------------------------------------------------------------- +# End of od_parse +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/od/odput.x b/pkg/utilities/nttools/stxtools/od/odput.x new file mode 100644 index 00000000..d02f59a5 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/odput.x @@ -0,0 +1,50 @@ +include "od.h" + +#--------------------------------------------------------------------------- +.help od_put Feb93 source +.ih +NAME +od_put -- Put the data in the file. +.ih +USAGE +.nf +call od_putd (od, data) +.fi +.ih +ARGUMENTS +.ls od (input: pointer) +The OD I/O descriptor. +.le +.ls data (input: double[ARB]) +The data to put in the OD file. +.le +.endhelp +#--------------------------------------------------------------------------- +procedure od_put (od, data) + +pointer od # I: The OD I/O descriptor. +double data[ARB] # I: The data. + +# Functions +pointer impl1d() + +errchk impl1d, tbcptd + +begin + # Check if a file is actually opened. If not, do nothing. + if (od != NULL) { + + # Get data depending on file type. + switch (OD_TYPE(od)) { + case OD_TABLE: + call tbcptd (OD_FD(od), OD_CD(od,OD_GRP(od)), data, + 1, OD_LEN(od)) + + case OD_IMAGE: + call amovd (data, Memd[impl1d (OD_FD(od))], OD_LEN(od)) + } + } +end +#--------------------------------------------------------------------------- +# End of od_put +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/od/odsetn.x b/pkg/utilities/nttools/stxtools/od/odsetn.x new file mode 100644 index 00000000..3abf97f7 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/odsetn.x @@ -0,0 +1,29 @@ +include +include "od.h" + +#--------------------------------------------------------------------------- +.help od_set_len Jun93 source +.ih +NAME +od_set_len -- Set the length of data. +.ih +DESCRIPTION +This sets how much data is read/written from the OD file. For images, +the dimensionality is changed. For tables, it just changes how much +is read/written; nothing is physically changed about the table. +.endhelp +#--------------------------------------------------------------------------- +procedure od_set_len (od, len) + +pointer od # I: OD descriptor. +int len # I: New length. + +begin + OD_LEN(od) = len + if (OD_TYPE(od) == OD_IMAGE) { + IM_LEN(OD_FD(od),1) = len + } +end +#--------------------------------------------------------------------------- +# End of od_set_len +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/od/odunmp.x b/pkg/utilities/nttools/stxtools/od/odunmp.x new file mode 100644 index 00000000..e776ecd7 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/odunmp.x @@ -0,0 +1,44 @@ +include "od.h" + +#--------------------------------------------------------------------------- +.help od_unmap Feb93 source +.ih +NAME +od_unmap -- Close the 1D image. +.ih +USAGE +call od_unmap (od) +.ih +ARGUMENTS +.ls od (input/output: pointer) +The OD I/O descriptor. On return, the value will be NULL. +.le +.endhelp +#--------------------------------------------------------------------------- +procedure od_unmap (od) + +pointer od # I: The OD I/O descriptor. + +errchk tbtclo, imunmap, mfree + +begin + if (od != NULL) { + switch (OD_TYPE(od)) { + case OD_TABLE: + call tbtclo (OD_FD(od)) + call mfree (OD_CD_PTR(od), TY_POINTER) + case OD_IMAGE: + call mw_ctfree (OD_WL(od)) + call mw_ctfree (OD_LW(od)) + call mw_close (OD_MW(od)) + call imunmap (OD_FD(od)) + } + + call mfree (OD_WSYS_PTR(od), TY_CHAR) + call mfree (OD_NAME_PTR(od), TY_CHAR) + call mfree (od, TY_STRUCT) + } +end +#--------------------------------------------------------------------------- +# End of od_unmap +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/od/odwcsn.x b/pkg/utilities/nttools/stxtools/od/odwcsn.x new file mode 100644 index 00000000..e79a4154 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/od/odwcsn.x @@ -0,0 +1,39 @@ +include +include "od.h" + +#--------------------------------------------------------------------------- +.help od_wcs_open May93 source +.ih +NAME +od_wcs_open -- Open the WCS information for an image. +.endhelp +#--------------------------------------------------------------------------- +procedure od_wcs_open (od) + +pointer od # I: Image descriptor. + +pointer mw_openim() +pointer mw_sctran() +bool streq() + +begin + if (OD_TYPE(od) == OD_IMAGE) { + OD_MW(od) = mw_openim (OD_FD(od)) + call mw_gwattrs (OD_MW(od), 0, "system", OD_WSYS(od), SZ_LINE) + if (streq ("multispec", OD_WSYS(od))) { + call mw_seti (OD_MW(od), MW_USEAXMAP, NO) + OD_WL(od) = mw_sctran (OD_MW(od), "multispec", "logical", 3b) + OD_LW(od) = mw_sctran (OD_MW(od), "logical", "multispec", 3b) + } else { + OD_WL(od) = mw_sctran (OD_MW(od), "world", "logical", 1) + OD_LW(od) = mw_sctran (OD_MW(od), "logical", "world", 1) + } + } else { + OD_MW(od) = NULL + OD_LW(od) = NULL + OD_WL(od) = NULL + } +end +#--------------------------------------------------------------------------- +# End of od_wcs_open +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/postexit.x b/pkg/utilities/nttools/stxtools/postexit.x new file mode 100644 index 00000000..ebad32f9 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/postexit.x @@ -0,0 +1,52 @@ +include + +# POST_EXIT_HANDLER -- Post an error handler that exits with an error code + +# The standard behavior of an iraf program is to exit with an error code +# of zero regardless of whether program execution is halted with an error. +# This behavior complicates control of tasks by user scripts. To change this +# behavor, this procedure posts an error handler that exits the program with +# its error code set to the value passed to the error procedure. The exit +# procedure is only called of the program terminates with a non-zero error +# status and the program is being run at the host level. The latter +# restriction is in place because exiting a program running under the iraf +# command language (cl) hangs the command language. Since error handlers +# a run in the order that they are posted, this procedure should be called +# after any other error handlers you may have in your program. +# +# Nelson Zarate 30-Nov-95 original + +procedure post_exit_handler () + +#-- +extern exit_handler() +int clstati() + +begin + # Only post the exit handler if the task is being run in host mode + + if (clstati(CL_PRTYPE) == PR_HOST) + call onerror(exit_handler) +end + +# EXIT_HANDLER -- Error handler that exits the program, setting the error code + +procedure exit_handler (status) + +int status # i: program exit status +#-- + +begin + # Only take exit if error status is non-zero (not OK) + + if (status != OK) { + # Must clean up file i/o first + # The OK flag flushes the buffers + + call fio_cleanup (OK) + + # Take the error exit with the specified status + + call errxit (status) + } +end diff --git a/pkg/utilities/nttools/stxtools/savgol.x b/pkg/utilities/nttools/stxtools/savgol.x new file mode 100644 index 00000000..48958ede --- /dev/null +++ b/pkg/utilities/nttools/stxtools/savgol.x @@ -0,0 +1,140 @@ +# Define some memory management. +define A Memd[a+((($2)-1)*(m+1))+($1)-1] +define B Memd[b+($1)-1] + +#--------------------------------------------------------------------------- +.help savgol Jun93 source +.ih +NAME +savgol -- Create a kernel for Savitzky-Golay smoothing. +.ih +USAGE +call savgol (c, np, nl, nr, ld, m) +.ih +ARGUMENTS +.ls c (O: double[np]) +The smoothing kernel in "wrap-around" order. See discussion for +details. +.le +.ls np (I: int) +The number of points allocated in the array represented by the "c" +argument. +.le +.ls nl (I: int) +Size of the kernel "to the left" of the central point. See discussion +for more details. +.le +.ls nr (I: int) +Size of the kernel "to the right" of the central point. See discussion +for more details. +.le +.ls ld (I: int) +Order of the derivative desired. Should be 0 for smoothing, higher +for smoothed versions of the specified derivative. +.le +.ls m (I: int) +Order of the smoothing polynomial. Should be 0 or 1 for standard +"boxcar" or "moving window" averaging. +.le +.ih +DISCUSSION +For an introduction to Savitzky-Golay filtering, see: + +.nf + Press, Teukolsky, Vetterling, & Falnnery, "Numeric Recipies: + The Art of Scientifitc Computing, Second Edition", Cambridge, + 1992. +.fi + +This routine returns the set of Savitzky-Golay smoothing coefficients +given the size, order of smoothing polynomial, and derivative to +return. The coefficients are returned in "wrap-around" order. Thus, +if the smoothing coefficients are C[-nl]...C[0]...C[nr], they are +returned in the array, c[i], as follows: + +.nf + c[1], c[2], c[3], ..., c[nl+1],c[nl+2],...,c[np-1],c[np] + + C[0], C[-1], C[-2],..., C[-nl], C[nr], ...,C[2], C[1] +.fi + +A code fragment to transform the array c[i] to the orginal order, +k[i], is: + +.nf + do i = 1, nl+1 + k[i] = c[nl+2-i] + do i = 1, nr + k[nl+1+i] = c[np+1-i] +.fi + +Array k[i], is now suitable for routines such as the IRAF VOPS routine +acnvrd. +.endhelp +#--------------------------------------------------------------------------- +procedure savgol (c, np, nl, nr, ld, m) + +double c[np] # O: The kernel. +int np # I: Size of the smoothing kernel. +int nl # I: Points to the left of center. +int nr # I: Points to the right of center. +int ld # I: Order of derivative to return. +int m # I: Order of the smoothing polynomial. + +int imj, ipj, j, k, kk, mm, ix +double d, fac, sum +pointer indx, a, b, sp +int shifti() + +begin + call smark (sp) + # Check input parameters. + if (np < nl+nr+1 || nl < 0 || nr < 0 || ld > m || nl+nr < m) + call error (1, "savgol: invalid inputs") + + # Allocate memory. + call salloc (indx, m+1, TY_INT) + call salloc (a, (m+1)**2, TY_DOUBLE) + call salloc (b, m+1, TY_DOUBLE) + + # Do it. + ipj = shifti (m, 1) + do ipj = 0, shifti (m, 1) { + if (ipj != 0) + sum = 0.d0 + else + sum = 1.d0 + do k = 1, nr + sum = sum + k**ipj + do k = 1, nl + sum = sum + (-k)**ipj + mm = min (ipj, 2*m-ipj) + do imj = -mm, mm, 2 + A(1+(ipj-imj)/2,1+(ipj+imj)/2) = sum + } + call ludcmd (Memd[a], m+1, m+1, Memi[indx], d, ix) + if (ix != OK) + call error (1, "savgol: singular matrix") + do j = 1, m+1 + B(j) = 0.d0 + B(ld+1) = 1.d0; + call lubksd (Memd[a], m+1, m+1, Memi[indx], Memd[b]) + do kk = 1, np + c[kk] = 0.d0 + do k = -nl, nr { + sum = B(1) + fac = 1.d0 + do mm = 1, m { + fac = fac * k + sum = sum + B(mm+1) * fac + } + kk = mod (np - k, np) + 1 + c[kk] = sum + } + + # That's all folks. + call sfree (sp) +end +#--------------------------------------------------------------------------- +# End of savgol +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sbuf.h b/pkg/utilities/nttools/stxtools/sbuf.h new file mode 100644 index 00000000..cda82d9b --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sbuf.h @@ -0,0 +1,15 @@ +#--------------------------------------------------------------------------- +.help sbuf.h Feb93 source +.ih +NAME +sbuf.h -- Memory structure for long strings. +.endhelp +#--------------------------------------------------------------------------- +define SB_LEN Memi[$1] # Current length of string. +define SB_MAXLEN Memi[$1+1] # Current maximum size of buffer. +define SB_PTR Memi[$1+2] # Pointer to the string array. +define SB_BUF Memc[SB_PTR($1)+$2] +define SB_SZ_SB 3 # Size of memory structure. +#--------------------------------------------------------------------------- +# End of sbuf.h +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sbuf.x b/pkg/utilities/nttools/stxtools/sbuf.x new file mode 100644 index 00000000..a5bead52 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sbuf.x @@ -0,0 +1,110 @@ +include "sbuf.h" + +#--------------------------------------------------------------------------- +.help sbuf Mar93 source +.ih +NAME +.nf +sb_open -- Open an sbuf. +sb_cat -- Add a string to the end of sbuf. +sb_close -- Close an sbuf. +sb_string -- Get the string to an sbuf. +.fi +.ih +USAGE +.nf +sb = sb_open() +call sb_cat (sb, str) +call sb_close (sb) +str_ptr = sb_string (sb) +.fi +.ih +ARGUMENTS +.ls sb (pointer :input/output) +The string buffer descriptor. +.le +.ls str (char[ARB] :input) +The string to append to the string buffer. +.le +.ls str_ptr (pointer :output) +A pointer to a string array containing the contents of the string buffer. +When done, the user is required to deallocate this memory using the call +"call mfree (str_ptr, TY_CHAR)". +.le +.ih +DISCUSSION +This interface allows one to handle arbitrarily long strings without +having to worry about the memory management. + +There may be other utility routines to add; feel free to do so. +.endhelp +#--------------------------------------------------------------------------- +pointer procedure sb_open + +pointer sb # The sbuf pointer + +errchk malloc + +begin + call malloc (sb, SB_SZ_SB, TY_STRUCT) + call malloc (SB_PTR(sb), SZ_LINE, TY_CHAR) + SB_LEN(sb) = 0 + SB_MAXLEN(sb) = SZ_LINE + + return (sb) +end +#--------------------------------------------------------------------------- +# End of sb_open +#--------------------------------------------------------------------------- +procedure sb_close (sb) + +pointer sb # IO: The sbuf descriptor, NULL on exit. + +errchk mfree + +begin + if (sb != NULL) { + call mfree (SB_PTR(sb), TY_CHAR) + call mfree (sb, TY_STRUCT) + } +end +#--------------------------------------------------------------------------- +# End of sb_close +#--------------------------------------------------------------------------- +pointer procedure sb_string (sb) + +pointer sb # I: The sbuf descriptor. + +pointer str # New string pointer. + +begin + call malloc (str, SB_LEN(sb), TY_CHAR) + call strcpy (SB_BUF(sb,0), Memc[str], SB_LEN(sb)) + + return (str) +end +#--------------------------------------------------------------------------- +# End of sb_string +#--------------------------------------------------------------------------- +procedure sb_cat (sb, str) + +pointer sb # I: The sbuf descriptor. +char str[ARB] # I: The string to concatenate. + +int i, strlen() # Length of input string. + +errchk realloc + +begin + i = strlen (str) + if (i + SB_LEN(sb) >= SB_MAXLEN(sb)) { + SB_MAXLEN(sb) = SB_MAXLEN(sb) + i + SZ_LINE + call realloc (SB_PTR(sb), SB_MAXLEN(sb), TY_CHAR) + } + + call strcpy (str, SB_BUF(sb,SB_LEN(sb)), i) + SB_LEN(sb) = SB_LEN(sb) + i +end +#--------------------------------------------------------------------------- +# End of sb_cat +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sgcone.x b/pkg/utilities/nttools/stxtools/sgcone.x new file mode 100644 index 00000000..074f4089 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sgcone.x @@ -0,0 +1,94 @@ +#--------------------------------------------------------------------------- +.help sg_convolve Jun93 source +.ih +NAME +sg_convolve -- Convolve an array using Savitzky-Golay filter. +.ih +USAGE +call sg_convolve (size, order, in, out, n) +.ih +ARGUMENTS +.ls size (I: int) +The full size of the smoothing kernel. If less than or equal to 1, +then no convolving takes place. +.le +.ls order (I: int) +The order of the smoothing polynomial. For normal "boxcar" smoothing, +this should be 0 or 1. Greater values preserve higher order terms in the +original data. Larger sizes are needed for this to be effective. +.le +.ls in (I: double[n]) +The data array to be convolved. +.le +.ls out (O: double[n]) +The convolved array. May be the same as the input array. +.le +.ih +DESCRIPTION +The routine, savgol, is used to calculate a Savitsky-Golay convolving +kernel. This kernel is then applied, using standard routines, to the +input data. See the routine savgol for more information. +.ih +SEE ALSO +savgol +.endhelp +#--------------------------------------------------------------------------- +procedure sg_convolve (size, order, in, out, n) + +int size # I: The size of the filter. +int order # I: The order to preserve while filtering. +double in[n] # I: Data to be convolved. +double out[n] # O: The convolved data. +int n # I: Length of the arrays. + +# Kernel parameters. +int half # Half size of kernel. +int isize # Odd size of kernel. +pointer k, kx # The kernel in real/double-wrap versions. + +# Misc. +pointer adx # Generic double array. +int i # Generic. +pointer sp # Stack pointer. + +begin + call smark (sp) + + # Fix the kernel size to be odd. + half = size / 2 + isize = half * 2 + 1 + + # Make sure there is something to convolve. If not, just copy and + # run. + if (isize <= 1) + call amovd (in, out, n) + else { + call salloc (k, isize, TY_REAL) + call salloc (kx, isize, TY_DOUBLE) + call salloc (adx, n+isize, TY_DOUBLE) + + # Compute the kernel. + call savgol (Memd[kx], isize, half, half, 0, order) + do i = 0, half + Memr[k+i] = Memd[kx+half-i] + do i = 0, half-1 + Memr[k+half+i+1] = Memd[kx+isize -i-1] + + # Put the data in the extended array and pad the ends as + # constants. + call amovd (in, Memd[adx+half], n) + do i = 1, half { + Memd[adx+half-i] = in[1] + Memd[adx+half+n+i-1] = in[n] + } + + # Filter it. + call acnvrd (Memd[adx], out, n, Memr[k], isize) + } + + # That's all folks. + call sfree (sp) +end +#--------------------------------------------------------------------------- +# End of sg_convolve +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/similar.x b/pkg/utilities/nttools/stxtools/similar.x new file mode 100644 index 00000000..a7b1a644 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/similar.x @@ -0,0 +1,127 @@ +define SZ_STACK 25 + +# SIMILAR -- Return a score base on the similarity between two strings + +# This procedure returns a number representing the similarity between +# two strings. The number is computed by finding the combined length of +# all the common substrings between the two strings, normalized to a value +# between zero and one hundred. +# +# B.Simon 13-Mar-89 Original + +int procedure similar (str1, str2) + +char str1[ARB] # i: First string +char str2[ARB] # i: Second string +#-- +int score, istack, len1, len2, maxch, ic, nc +pointer stack[4,SZ_STACK] +pointer sp, word1, word2, s1, s2 +pointer start1, end1, start2, end2, newstart1, newend1, newstart2, newend2 + +string overflow "Stack overflow in procedure similar" + +int strlen() + +begin + # If either string is zero length, return zero as score + + score = 0 + len1 = strlen (str1) + len2 = strlen (str2) + if (len1 == 0 || len2 == 0) + return (score) + + # Compare the lower case version of the strings + + call smark (sp) + call salloc (word1, len1, TY_CHAR) + call salloc (word2, len2, TY_CHAR) + + call strcpy (str1, Memc[word1], len1) + call strlwr (Memc[word1]) + + call strcpy (str2, Memc[word2], len2) + call strlwr (Memc[word2]) + + # The first substrings to compare are the entire strings + + istack = 1 + stack[1,istack] = word1 + stack[2,istack] = word1 + len1 - 1 + stack[3,istack] = word2 + stack[4,istack] = word2 + len2 - 1 + + # While there are more substrings on the stack + + while (istack > 0) { + + # Find the longest match between the substrings + + maxch = 0 + start1 = stack[1,istack] + end1 = stack[2,istack] + start2 = stack[3,istack] + end2 = stack[4,istack] + + for (s1 = start1; s1 <= end1 - maxch; s1 = s1 + 1) { + + nc = end1 - s1 + + for (s2 = start2; s2 <= end2 - maxch; s2 = s2 + 1) { + + if (Memc[s1] == Memc[s2]) { + + # Compute the length of the match + + for (ic = 1; + ic <= nc && Memc[s1+ic] == Memc[s2+ic]; + ic = ic + 1) + ; + + # If this is the longest match so far, save + # the length and start and end points + + if (ic > maxch) { + maxch = ic + newstart1 = s1 + newstart2 = s2 + newend1 = s1 + ic - 1 + newend2 = s2 + ic - 1 + } + s2 = s2 + ic - 1 + } + } + } + + # Pop the stack and push the new substings on the stack + + istack = istack - 1 + if (maxch > 0) { + score = score + 2 * maxch + + if (start1 != newstart1 && start2 != newstart2) { + if (istack == SZ_STACK) + call error (1, overflow) + istack = istack + 1 + stack[1,istack] = start1 + stack[2,istack] = newstart1 - 1 + stack[3,istack] = start2 + stack[4,istack] = newstart2 - 1 + } + + if (end1 != newend1 && end2 != newend2) { + if (istack == SZ_STACK) + call error (1, overflow) + istack = istack + 1 + stack[1,istack] = newend1 + 1 + stack[2,istack] = end1 + stack[3,istack] = newend2 + 1 + stack[4,istack] = end2 + } + } + } + + call sfree (sp) + return (100 * score / (len1 + len2)) +end diff --git a/pkg/utilities/nttools/stxtools/sp_util/mkpkg b/pkg/utilities/nttools/stxtools/sp_util/mkpkg new file mode 100644 index 00000000..52a93adb --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/mkpkg @@ -0,0 +1,16 @@ +# Make the wcslab package + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + spchag.x + spdise.x + spmapt.x + sprote.x + spstry.x + sptras.x + spw2ld.x + spwcss.x diff --git a/pkg/utilities/nttools/stxtools/sp_util/spchag.x b/pkg/utilities/nttools/stxtools/sp_util/spchag.x new file mode 100644 index 00000000..f6292a4e --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/spchag.x @@ -0,0 +1,64 @@ +# sp_change_string - Replace a string with the indicated string. +# +# History +# 1Apr91 - Created by Jonathan D. Eisenhamer, STScI. +#--------------------------------------------------------------------------- + +procedure sp_change_string( input, old, new, output, max ) + +char input[ARB] # I: The input string. +char old[ARB] # I: The string segment to be replaced. +char new[ARB] # I: The string to replace the old with. +char output[ARB] # O: The modified input string. +int max # I: The maximun length of the output string. + +# Declarations. +int after # Next character position after match. +int first # First character position of matched string. +int ilen # Length of input. +int ip # Pointer into input. +int last # Last character position of matched string. +int old_len # Length of old. +int op # Pointer into output. + +# Function declarations. +int gstrcpy(), strlen(), gstrmatch() + +begin + + # Initialize the string pointers. + ip = 1 + op = 1 + ilen = strlen( input ) + old_len = strlen( old ) + + # Keep going until either the input string has been completely copied + # or the output string is full. + while( ip < ( ilen + 1 ) && op < ( max + 1 ) ) { + + # Search for the old string. + after = gstrmatch( input[ip], old, first, last ) + + # If the string is not found, then copy the rest of the input to the + # output. + if( after == 0 ) { + call strcpy( input[ip], output[op], max - op + 1 ) + ip = ilen + 1 + } + + # The old string is found, copy the input up to the old string + # and replace the old string. + else { + first = min( first - 1, max - op + 1 ) + call sp_strncpy( input[ip], first, output[op] ) + ip = ip + last + op = op + first + op = op + gstrcpy( new, output[op], max - op + 1 ) + } + + } + +end +#--------------------------------------------------------------------------- +# End of sp_change_string +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sp_util/spdise.x b/pkg/utilities/nttools/stxtools/sp_util/spdise.x new file mode 100644 index 00000000..9985c790 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/spdise.x @@ -0,0 +1,44 @@ +# sp_distanced - Determine the distance between two points. +# +# History +# 4Dec90 - Created by Jonathan D. Eisenhamer, STScI. +#--------------------------------------------------------------------------- + +double procedure sp_distanced( x1, y1, x2, y2 ) + +double x1, y1, x2, y2 + +double a, b + +begin + + a = x1 - x2 + b = y1 - y2 + return( sqrt( ( a * a ) + ( b * b ) ) ) + +end +#--------------------------------------------------------------------------- +# End of sp_distanced +#--------------------------------------------------------------------------- +# sp_distancer - Determine the distance between two points. +# +# History +# 4Dec90 - Created by Jonathan D. Eisenhamer, STScI. +#--------------------------------------------------------------------------- + +real procedure sp_distancer( x1, y1, x2, y2 ) + +real x1, y1, x2, y2 + +real a, b + +begin + + a = x1 - x2 + b = y1 - y2 + return( sqrt( ( a * a ) + ( b * b ) ) ) + +end +#--------------------------------------------------------------------------- +# End of sp_distancer +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sp_util/spmapt.x b/pkg/utilities/nttools/stxtools/sp_util/spmapt.x new file mode 100644 index 00000000..cef87fed --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/spmapt.x @@ -0,0 +1,94 @@ +include + +# Default viewport edges. +define EDGE1 0.1 +define EDGE2 0.9 +define EDGE3 0.12 +define EDGE4 0.85 + +#--------------------------------------------------------------------------- +.help sp_map_viewport Sep92 source +.ih +NAME +sp_map_viewport -- set device viewport for contour plots. +.endhelp +#--------------------------------------------------------------------------- + +procedure sp_map_viewport (gp, ncols, nlines, ux1, ux2, uy1, uy2, pre, perim) + +pointer gp # I: pointer to graphics descriptor +real ncols, nlines # I: size of image area, after block reduction +real ux1, ux2, uy1, uy2 # I: NDC coordinates of requested viewort +bool pre # I: Preserve aspect ratio. +bool perim # I: draw perimeter + +real xcen, ycen, x, y +real aspect_ratio +real x1, x2, y1, y2, ext, xdis, ydis +data ext /0.0625/ +real ggetr() + +begin + # Determine the standard window sizes. + if (!pre && !perim) { + 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 + + 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 preserving aspect ratio, + # modify viewport to correctly display the contour aspect. + if (pre) { + aspect_ratio = ggetr (gp, "ar") + if (aspect_ratio == 0.0) { + x = ggetr (gp, "xr") + y = ggetr (gp, "yr") + if ( x != 0.0 && y != 0.0) + aspect_ratio = y / x + else + aspect_ratio = 1.0 + } + aspect_ratio = nlines / ncols / aspect_ratio + x = ydis / aspect_ratio + y = ydis + if ( x > xdis) { + y = aspect_ratio * xdis + x = xdis + } + xdis = x + ydis = y + } + + # All set. + 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, 1.0, ncols, 1.0, nlines) + +end +#--------------------------------------------------------------------------- +# End of sp_map_viewport +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sp_util/sprote.x b/pkg/utilities/nttools/stxtools/sp_util/sprote.x new file mode 100644 index 00000000..c9baeb65 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/sprote.x @@ -0,0 +1,49 @@ +include + +# The dimensionality. +define N_DIM 2 + +# Define some memory management. +define ONER Memr[$1+$2-1] + +# sp_rotate - Rotate a vector. +# +# History +# 8Mar91 - Created by Jonathan D. Eisenhamer, STScI. +#--------------------------------------------------------------------------- + +procedure sp_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 translated vectors. + +# Declarations +pointer center # To specify the center. +pointer mw # MWCS structure. +pointer sp # Stack pointer. + +# Function prototypes. +pointer mw_open(), mw_sctran() + +begin + + # Suck 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 +#--------------------------------------------------------------------------- +# End of sp_rotate +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sp_util/spstry.x b/pkg/utilities/nttools/stxtools/sp_util/spstry.x new file mode 100644 index 00000000..545b0b06 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/spstry.x @@ -0,0 +1,24 @@ +# sp_strncpy - Counted character copy. +# +# History +# 1Apr91 - Created by Jonathan D. Eisenhamer, STScI. +#--------------------------------------------------------------------------- + +procedure sp_strncpy( input, n_chars, output ) + +char input[ARB] # I: The input string to copy to the output. +int n_chars # I: The number of characters to copy. +char output[ARB] # O: The output string. + +# Declarations. +int i # Index. + +begin + + for( i = 1; i <= n_chars; i = i + 1 ) + output[i] = input[i] + +end +#--------------------------------------------------------------------------- +# End of sp_strncpy. +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sp_util/sptras.x b/pkg/utilities/nttools/stxtools/sp_util/sptras.x new file mode 100644 index 00000000..f62e9ceb --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/sptras.x @@ -0,0 +1,35 @@ +# Set the dimensionality +define N_DIM 2 + +# sp_trans - Translate the origin to a new center. +# +# History +# 11Mar91 - Created by Jonathan D. Eisenhamer, STScI. +#--------------------------------------------------------------------------- + +procedure sp_trans( x, y, npts, center, nx, ny ) + +real x[npts], y[npts] # I: The x, y vectors to translate. +int npts # I: The number of points in the vectors. +real center[N_DIM] # I: The new coordinate center. +real nx[npts], ny[npts] # O: The translated vectors. + +# Declarations +pointer mw # MWCS structure. + +# Function prototypes. +pointer mw_open(), mw_sctran() + +begin + + mw = mw_open( NULL, N_DIM ) + call mw_shift( mw, center, 3b ) + call mw_v2tranr( mw_sctran( mw, "physical", "logical", 3b ), + x, y, nx, ny, npts ) + + call mw_close( mw ) + +end +#--------------------------------------------------------------------------- +# End of sp_trans +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sp_util/spw2ld.x b/pkg/utilities/nttools/stxtools/sp_util/spw2ld.x new file mode 100644 index 00000000..a31ce22d --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/spw2ld.x @@ -0,0 +1,50 @@ +# sp_w2ld - Transform world coordinates to logical coordinates (double). +# +# History +# 24Jun91 - Created by Jonathan D. Eisenhamer, STScI. +#--------------------------------------------------------------------------- + +procedure sp_w2ld( wlct, flip, wx, wy, lx, ly, npts ) + +pointer wlct # I: The MWCS coordinate trans. descriptor. +bool 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 ) + call mw_v2trand( wlct, wx, wy, ly, lx, npts ) + else + call mw_v2trand( wlct, wx, wy, lx, ly, npts ) + +end +#--------------------------------------------------------------------------- +# End of sp_w2ld +#--------------------------------------------------------------------------- +# sp_l2wd - Transform logical coordinates to world coordinates (double). +# +# History +# 24Jun91 - Created by Jonathan D. Eisenhamer, STScI. +#--------------------------------------------------------------------------- + +procedure sp_l2wd( lwct, flip, lx, ly, wx, wy, npts ) + +pointer lwct # I: The MWCS coordinate trans. descriptor. +bool 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 ) + call mw_v2trand( lwct, ly, lx, wx, wy, npts ) + else + call mw_v2trand( lwct, lx, ly, wx, wy, npts ) + +end +#--------------------------------------------------------------------------- +# End of sp_l2wd +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/sp_util/spwcss.x b/pkg/utilities/nttools/stxtools/sp_util/spwcss.x new file mode 100644 index 00000000..bb2feb49 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/sp_util/spwcss.x @@ -0,0 +1,90 @@ +include +include + +#--------------------------------------------------------------------------- +.help sp_wcsparams 3Aug95 source +.ih +NAME +sp_wcsparams -- Read the WCS descriptor from the parameters. +.ih +DESCRIPTION +This procedure returns the WCS descriptor created from task parameters +and the logical space that will be graphed. +.ih +BUGS +This only deals with two axes. +.endhelp +#--------------------------------------------------------------------------- +procedure sp_wcsparams( mw, log_x1, log_x2, log_y1, log_y2 ) + +pointer mw # O: The MWCS descriptor. +real log_x1, log_x2, + log_y1, log_y2 # O: The extent of the logical space to graph. + +# Declarations. +pointer b # Buffer pointer. +double clgetd() # Get double-valued parameter. +real clgetr() # Get real-valued parameter. +pointer im # Temporary image descriptor. +pointer immap() # Open an image. +pointer impl2s() # Put line in 2d image. +pointer imw # Temporary MWCS descriptor. +pointer mw_newcopy() # Copy MWCS descriptor. +pointer mw_openim() # Get MWCS descriptor from image. +char s[SZ_LINE] # Generic string. + +string tmpimage ".SPWCSS" + +begin + # Since no one knows how mwcs really works, we cheat. + # Create an image and set the header keywords to what + # the parameters are. Then use the image load to get the + # mwcs instead of trying to create it from scratch. + + # Create an image. + iferr (call imdelete (tmpimage)) + ; + im = immap (tmpimage, NEW_IMAGE, 20000) + IM_NDIM(im) = 2 + IM_LEN(im,1) = 1 + IM_LEN(im,2) = 1 + IM_PIXTYPE(im) = TY_SHORT + + # Now populate the WCS-relevant keywords. + call clgstr ("ctype1", s, SZ_LINE) + call imastr (im, "ctype1", s) + call clgstr ("ctype2", s, SZ_LINE) + call imastr (im, "ctype2", s) + call imaddd (im, "crpix1", clgetd ("crpix1")) + call imaddd (im, "crpix2", clgetd ("crpix2")) + call imaddd (im, "crval1", clgetd ("crval1")) + call imaddd (im, "crval2", clgetd ("crval2")) + call imaddd (im, "cd1_1", clgetd ("cd1_1")) + call imaddd (im, "cd1_2", clgetd ("cd1_2")) + call imaddd (im, "cd2_1", clgetd ("cd2_1")) + call imaddd (im, "cd2_2", clgetd ("cd2_2")) + + # Write a pixel, close and reopen the image. + b = impl2s (im, 1) + call imunmap (im) + im = immap (tmpimage, READ_ONLY, 0) + + # Retrieve the MWCS descriptor. Make a copy so we can close the + # temporary image. + imw = mw_openim (im) + mw = mw_newcopy (imw) + + # Get the logical workspace. + log_x1 = clgetr ("log_x1") + log_x2 = clgetr ("log_x2") + log_y1 = clgetr ("log_y1") + log_y2 = clgetr ("log_y2") + + # That's all folks. + call mw_close (imw) + call imunmap (im) + call imdelete (tmpimage) +end +#--------------------------------------------------------------------------- +# End of sp_wcsparams +#--------------------------------------------------------------------------- diff --git a/pkg/utilities/nttools/stxtools/strjust.x b/pkg/utilities/nttools/stxtools/strjust.x new file mode 100644 index 00000000..5f50f080 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/strjust.x @@ -0,0 +1,31 @@ +include + +# STRJUST -- Remove whitspace from a string and convert to lower case +# +# B.Simon 30-Jan-95 copied from synphot$strfix + +procedure strjust (str) + +char str[ARB] # u: string to convert +#-- +int ic, jc + +begin + jc = 1 + for (ic = 1; str[ic] != EOS; ic = ic + 1) { + if (IS_WHITE(str[ic])) + next + + if (IS_UPPER(str[ic])) { + str[jc] = TO_LOWER(str[ic]) + + } else if (jc < ic) { + str[jc] = str[ic] + } + + jc = jc + 1 + } + + str[jc] = EOS +end + diff --git a/pkg/utilities/nttools/stxtools/stxgetcoord.x b/pkg/utilities/nttools/stxtools/stxgetcoord.x new file mode 100644 index 00000000..0fc9842c --- /dev/null +++ b/pkg/utilities/nttools/stxtools/stxgetcoord.x @@ -0,0 +1,182 @@ +include +include +include + +define SZ_PNAME 8 + +# stx_getcoord -- get coordinate parameters +# This procedure gets the coordinate parameters from an image. +# The parameter values are gotten via mwcs, and the lterm is factored +# into the wterm so that the parameters are relative to the actual image +# section that was opened rather than to the "original" image. +# +# Phil Hodge, 5-Jan-1993 Copied from fourier$lib/loadct.x. +# Phil Hodge, 2-Feb-1994 Errchk mwcs routines. + +procedure stx_getcoord (im, crpix, crval, cd, maxdim, ctype, maxch) + +pointer im # i: pointer to imhdr struct for input image +double crpix[ARB] # o: reference pixel +double crval[ARB] # o: coordinates at reference pixel +double cd[maxdim,maxdim] # o: derivatives of l & m with respect to x & y +int maxdim # i: dimension of arrays (e.g. IM_MAXDIM) +char ctype[maxch,maxdim] # o: coord. type of each axis (e.g. "RA---TAN") +int maxch # i: size of ctype string (e.g. SZ_CTYPE) +#-- +pointer mw + +double o_crval[IM_MAXDIM] # world coordinates at reference pixel +double o_crpix[IM_MAXDIM] # not corrected for image section +double o_cd[IM_MAXDIM,IM_MAXDIM] # wterm only (not corr. for section) + +double n_crpix[IM_MAXDIM] # corrected for image section +double n_cd[IM_MAXDIM,IM_MAXDIM] # CD matrix corrected for section + +double ltm[IM_MAXDIM,IM_MAXDIM] # lterm matrix +double i_ltm[IM_MAXDIM,IM_MAXDIM] # inverse of ltm +double ltv[IM_MAXDIM] # lterm vector + +int ndim # dimension of image +int wcsdim # dimension of mwcs coordinates +pointer mw_openim() +int mw_stati() +errchk mw_openim, mw_stati, mw_gwtermd, mw_gltermd, mw_invertd, mw_close, + stx_extract + +begin + ndim = IM_NDIM(im) + if (ndim > maxdim) + call error (1, + "stx_getcoord: dimension of image is larger than array size") + + mw = mw_openim (im) + wcsdim = mw_stati (mw, MW_NPHYSDIM) # get mwcs dimension + + # Get the wterm and the lterm. + call mw_gwtermd (mw, o_crpix, o_crval, o_cd, wcsdim) + call mw_gltermd (mw, ltm, ltv, wcsdim) + + # Convert the wterm to be the values relative to the current + # image section. (Comments & code copied from mwcs.) + + # Output CRPIX = R' = (LTM * R + LTV). + call mw_vmuld (ltm, o_crpix, n_crpix, wcsdim) + call aaddd (ltv, n_crpix, n_crpix, wcsdim) + + # Output CD matrix = CD' = (CD * inv(LTM)). + call mw_invertd (ltm, i_ltm, wcsdim) + call mw_mmuld (o_cd, i_ltm, n_cd, wcsdim) + + # Extract the coordinate parameters, and get ctype. + call stx_extract (im, mw, n_crpix, o_crval, n_cd, wcsdim, + crpix, crval, cd, maxdim, ctype, maxch) + + call mw_close (mw) + + # Check for invalid CD matrix. + if (ndim == 1) { + if (cd[1,1] == 0.d0) { + call eprintf ("warning: pixel spacing = 0; reset to 1\n") + cd[1,1] = 1.d0 + } + } else if (ndim == 2) { + if (cd[1,1] * cd[2,2] - cd[1,2] * cd[2,1] == 0.d0) { + call eprintf ( + "warning: CD matrix is singular; reset to identity matrix\n") + cd[1,1] = 1.d0 + cd[2,1] = 0.d0 + cd[1,2] = 0.d0 + cd[2,2] = 1.d0 + } + } +end + +# stx_extract -- extract coordinate parameters +# This routine is needed to take care of the situation where the dimension +# of the input image was reduced by taking an image section. In that case, +# the coordinate information gotten using mwcs has the dimension of the +# original image, which results in two problems. (1) We need to know which +# axis of the original image maps to which axis of the image that we've +# got. (2) We have to dimension the CD matrix differently. When MWCS +# puts values into a 2-D array it is dimensioned wcsdim X wcsdim, but we +# declared it maxdim X maxdim in the calling routine. In this routine +# we declare the input CD matrix to be wcsdim X wcsdim, while the output +# CD matrix is maxdim X maxdim. + +procedure stx_extract (im, mw, n_crpix, n_crval, n_cd, wcsdim, + crpix, crval, cd, maxdim, ctype, maxch) + +pointer im # i: pointer to imhdr struct for input image +pointer mw # i: mwcs pointer +double n_crpix[wcsdim] # i: crpix +double n_crval[wcsdim] # i: crval +double n_cd[wcsdim,wcsdim] # i: CD matrix +int wcsdim # i: dimension of wcs +double crpix[maxdim] # o: crpix extracted from n_crpix +double crval[maxdim] # o: crval extracted from n_crval +double cd[maxdim,maxdim] # o: CD matrix extracted from n_cd +int maxdim # i: dimension of arrays (e.g. IM_MAXDIM) +char ctype[maxch,maxdim] # o: coord. type of each axis (e.g. "RA---TAN") +int maxch # i: size of ctype string (e.g. SZ_CTYPE) +#-- +char keyword[SZ_PNAME] # keyword for getting ctype +int ndim # actual dimension of image +int axno[IM_MAXDIM] # axis numbers +int axval[IM_MAXDIM] # ignored +int ax[IM_MAXDIM] # physical axis number for each logical axis +int i, j +bool ax_ok # for checking that axis numbers were found +int imaccf() +errchk mw_gaxmap + +begin + ndim = IM_NDIM(im) + + # Get the axis mapping. + call mw_gaxmap (mw, axno, axval, wcsdim) + + # Find the image axis numbers corresponding to the mwcs numbers. + do i = 1, ndim # initialize + ax[i] = 0 + do j = 1, wcsdim { + do i = 1, ndim { + if (axno[j] == i) { + ax[i] = j + break + } + } + } + + # It's an error if any axis number was not found. + ax_ok = true # initial value + do i = 1, ndim { + if (ax[i] < 1) + ax_ok = false + } + if (!ax_ok) { +# call error (1, "stx_extract: mwcs axis mapping is messed up") +# This is a temporary fix to prevent crashing on a vax. + do i = 1, ndim + ax[i] = i + } + + # Extract crpix, crval and the CD matrix. + # Note that we transpose the CD matrix because of different + # conventions regarding how a matrix is stored. + do i = 1, ndim { + crpix[i] = n_crpix[ax[i]] + crval[i] = n_crval[ax[i]] + do j = 1, ndim + cd[i,j] = n_cd[ax[j],ax[i]] # transpose + } + + # Get ctype. + do i = 1, ndim { + call sprintf (keyword, SZ_PNAME, "ctype%d") + call pargi (ax[i]) # physical axis number + if (imaccf (im, keyword) == YES) + call imgstr (im, keyword, ctype[1,i], maxch) + else + call strcpy ("PIXEL", ctype[1,i], maxch) + } +end diff --git a/pkg/utilities/nttools/stxtools/template.h b/pkg/utilities/nttools/stxtools/template.h new file mode 100644 index 00000000..9df66f37 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/template.h @@ -0,0 +1,21 @@ +# TEMPLATE.H -- Structure used to expand image names over groups + +define LEN_TPSTRUCT 5 + +define TP_ROOTPTR Memi[$1] # Pointer to image root name +define TP_SECTPTR Memi[$1+1] # Pointer to image section +define TP_START Memi[$1+2] # First group +define TP_COUNT Memi[$1+3] # Total number of groups +define TP_INDEX Memi[$1+4] # Current group + +define TP_ROOT Memc[TP_ROOTPTR($1)] +define TP_SECT Memc[TP_SECTPTR($1)] + +define TP_EXT_LIST "|stf|fxf|oif|plf|qpf|" + +define TP_UNKNOWN 0 +define TP_GEIS 1 +define TP_FITS 2 +define TP_IRAF 3 +define TP_PIXLIST 4 +define TP_QPOE 5 diff --git a/pkg/utilities/nttools/stxtools/tpbreak.x b/pkg/utilities/nttools/stxtools/tpbreak.x new file mode 100644 index 00000000..be5aed1d --- /dev/null +++ b/pkg/utilities/nttools/stxtools/tpbreak.x @@ -0,0 +1,80 @@ +# TP_BREAK -- Break an image name into bracket delimeted substrings +# +# B.Simon 02-Jun-89 Original + +procedure tp_break (imname, part, npart, maxch) + +char imname[ARB] # i: Image name +char part[maxch,ARB] # o: Array of image name parts +int npart # i: Maximum number of parts +int maxch # i: Maximum length of part +#-- +bool inside +char ch +int ic, jc, ipart +pointer sp, errmsg + +string syntax "Syntax error in image name (%s)" + +begin + # Allocate memory for error message + + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Initialize output to null string + + do ipart = 1, npart + part[1,ipart] = EOS + + # Break image name into bracket delimeted components + # The variable inside is used as a check that brackets are paired + + jc = 1 + ipart = 1 + inside = false + + for (ic = 1; ipart <= npart && imname[ic] != EOS; ic = ic + 1) { + + ch = imname[ic] + if (ch == '\\') { + ic = ic + 1 + + } else if (ch == '[') { + if (inside) { + call sprintf (Memc[errmsg], SZ_LINE, syntax) + call pargstr (imname) + call error (1, Memc[errmsg]) + } + part[jc,ipart] = EOS + ipart = ipart + 1 + inside = true + jc = 1 + + } else if (ch == ']') { + if (! inside) { + call sprintf (Memc[errmsg], SZ_LINE, syntax) + call pargstr (imname) + call error (1, Memc[errmsg]) + } + inside = false + + } else if (ipart > 1 && ! inside) { + call sprintf (Memc[errmsg], SZ_LINE, syntax) + call pargstr (imname) + call error (1, Memc[errmsg]) + } + + part[jc,ipart] = imname[ic] + jc = jc + 1 + + if (jc > maxch) { + call sprintf (Memc[errmsg], SZ_LINE, syntax) + call pargstr (imname) + call error (1, Memc[errmsg]) + } + } + + part[jc,ipart] = EOS + call sfree (sp) +end diff --git a/pkg/utilities/nttools/stxtools/tpclose.x b/pkg/utilities/nttools/stxtools/tpclose.x new file mode 100644 index 00000000..8afac19c --- /dev/null +++ b/pkg/utilities/nttools/stxtools/tpclose.x @@ -0,0 +1,21 @@ +include "template.h" + +# TP_CLOSE -- Close the group template expansion routines + +# Free the dynamic memory used to store the group template structure +# +# B.Simon 28-Feb-89 Original +# B.Simon 21-Aug-91 Changed template structure + +procedure tp_close (ptr) + +pointer ptr # u: Pointer to list of file names +#-- +errchk mfree + +begin + call mfree (TP_ROOTPTR(ptr), TY_CHAR) + call mfree (TP_SECTPTR(ptr), TY_CHAR) + call mfree (ptr, TY_STRUCT) + ptr = NULL +end diff --git a/pkg/utilities/nttools/stxtools/tpcount.x b/pkg/utilities/nttools/stxtools/tpcount.x new file mode 100644 index 00000000..f233aa26 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/tpcount.x @@ -0,0 +1,134 @@ +include "template.h" + +# TP_COUNT -- Count the number of groups in an image +# +# B.Simon 02-Oct-98 Original +# B.Simon 26-Apr-99 Check value of NEXTEND before using + +int procedure tp_count (root) + +char root[ARB] # i: image name minus any sections +#-- +int imtype, count, lo, hi, mid +pointer sp, image, im + +int imgeti(), imaccf(), tp_imtype(), tp_hasgroup() +pointer immap() + +begin + # If the image is not a geis or fits file it can only have one group + + imtype = tp_imtype (root) + if (imtype != TP_GEIS && imtype != TP_FITS) + return (1) + + # Open the image to read the number of groups or extensions + # as recorded in the appropriate header keyword + + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + + call strcpy (root, Memc[image], SZ_FNAME) + call strcat ("[0]", Memc[image], SZ_FNAME) + + iferr (im = immap (Memc[image], READ_ONLY, NULL)) { + # If image can't be opened, report an error condition + + count = ERR + + } else if (imtype == TP_GEIS) { + # Number of groups is trustworthy, report it to user + + count = imgeti (im, "GCOUNT") + call imunmap (im) + + } else { + # Number of extensions is not, it must be checked + + lo = 1 + hi = 0 + + # Check number of extensions + + if (imaccf (im, "NEXTEND") == YES) { + mid = imgeti (im, "NEXTEND") + + if (mid > 0) { + if (tp_hasgroup (root, mid) == NO) { + hi = mid + + } else { + lo = mid + mid = mid + 1 + + if (tp_hasgroup (root, mid) == NO) { + hi = mid + } else { + lo = mid + } + } + } + } + + # Find bracket for number of extensions + + while (hi < lo) { + mid = 2 * lo + + if (tp_hasgroup (root, mid) == NO) { + hi = mid + } else { + lo = mid + } + } + + # Use binary search to find actual number of extensions + + while (hi - lo > 1) { + mid = (hi + lo) / 2 + + if (tp_hasgroup (root, mid) == NO) { + hi = mid + } else { + lo = mid + } + } + + count = lo + call imunmap (im) + } + + call sfree (sp) + return (count) +end + +# TP_HASGROUP -- Determine if group is preent in image + +int procedure tp_hasgroup (root, index) + +char root[ARB] # i: image name +int index # i: index of group to check +#-- +int has +pointer sp, image, im + +pointer immap() + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[image], SZ_FNAME, "%s[%d]") + call pargstr (root) + call pargi (index) + + iferr (im = immap (Memc[image], READ_ONLY, NULL)) { + has = NO + } else { + call imunmap (im) + has = YES + } + + call sfree (sp) + return (has) +end diff --git a/pkg/utilities/nttools/stxtools/tpfetch.x b/pkg/utilities/nttools/stxtools/tpfetch.x new file mode 100644 index 00000000..885fd847 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/tpfetch.x @@ -0,0 +1,43 @@ +include "template.h" + +# TP_FETCH -- Fetch the next image name from the group image template +# +# Create the next file name from the structure created by tp_open. +# Return true if another group exists, false otherwise. +# +# B.Simon 28-Feb-89 Original +# B.Simon 21-Aug-91 Changed template structure +# B.Simon 24-Jul-98 Revised to handle unparsable sections + +bool procedure tp_fetch (ptr, file_name) + +pointer ptr # i: A pointer to a list of file names +char file_name[SZ_FNAME] # o: The next file name in the list +#-- + +begin + if ((TP_INDEX(ptr) - TP_START(ptr)) + 1 > TP_COUNT(ptr)) + return (false) + + if (TP_START(ptr) == ERR) { + call sprintf (file_name, SZ_FNAME, "%s%s") + call pargstr (TP_ROOT(ptr)) + call pargstr (TP_SECT(ptr)) + + } else if (TP_COUNT(ptr) > 1 && TP_INDEX(ptr) == TP_START(ptr)) { + call sprintf (file_name, SZ_FNAME, "%s[%d/%d]%s") + call pargstr (TP_ROOT(ptr)) + call pargi (TP_INDEX(ptr)) + call pargi (TP_COUNT(ptr)) + call pargstr (TP_SECT(ptr)) + + } else { + call sprintf (file_name, SZ_FNAME, "%s[%d]%s") + call pargstr (TP_ROOT(ptr)) + call pargi (TP_INDEX(ptr)) + call pargstr (TP_SECT(ptr)) + } + + TP_INDEX(ptr) = TP_INDEX(ptr) + 1 + return (true) +end diff --git a/pkg/utilities/nttools/stxtools/tpgroup.x b/pkg/utilities/nttools/stxtools/tpgroup.x new file mode 100644 index 00000000..1dac1895 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/tpgroup.x @@ -0,0 +1,87 @@ +include +include + +# TP_GROUP -- Extract the group index and count from an image name +# +# B.Simon 02-Jun-89 Original +# B.Simon 10-Jul-98 Revised to ignore what it can't parse +# B.Simon 02-Oct-98 added call to tp_count +# B.Simon 26-Apr-99 set index to ERR if undefined + +procedure tp_group (root, gsect, def_count, index, count) + +char root[ARB] # i: Root section of image name +char gsect[ARB] # i: Group section of image name +int def_count # i: Default count if not specified +int index # o: Starting group index +int count # o: Group count +#-- +bool star +int ic, inum, num[2] + +int tp_count() + +begin + inum = 0 + num[1] = 0 + num[2] = 0 + star = false + + # Extract the numeric fields from the group section + # Set a flag if a star was found + + for (ic = 1; gsect[ic] != EOS; ic = ic + 1) { + switch (gsect[ic]) { + case ' ': + ; + case '[': + inum = 1 + case ']': + break + case '*': + star = true + inum = inum - 1 + case '/': + inum = inum + 1 + default: + if (! star && IS_DIGIT(gsect[ic])) { + if (inum > 2) { + inum = 2 + break + } + num[inum] = 10 * num[inum] + TO_INTEG(gsect[ic]) + + } else { + inum = 0 + star = false + break + } + } + } + + # Set the output variables according to the number of fields found + + switch (inum) { + case 0: + index = ERR + count = ERR + case 1: + index = num[1] + count = 1 + case 2: + index = num[1] + count = max (1, num[2]) + } + + # Either use the default count or if the default is zero, + # Open the image and read the count from it + + if (star) { + if (def_count > 0) { + count = def_count + + } else { + count = tp_count (root) + } + } +end diff --git a/pkg/utilities/nttools/stxtools/tpimtype.x b/pkg/utilities/nttools/stxtools/tpimtype.x new file mode 100644 index 00000000..3ed7580f --- /dev/null +++ b/pkg/utilities/nttools/stxtools/tpimtype.x @@ -0,0 +1,116 @@ +include +include "template.h" + +define MAXEXT 25 + +# TP_IMTYPE -- Determine image type from image extension +# +# B.Simon 02-Oct-98 Original + +int procedure tp_imtype (root) + +int root[ARB] # i: image extension +#-- +int loadext +pointer extlist[MAXEXT] +pointer extbuf + +data loadext / NO / + +int nc, iext, imtype +pointer sp, ext + +int fnextn(), strdic(), iki_validextn() + +begin + call smark (sp) + call salloc (ext, SZ_FNAME, TY_CHAR) + + if (loadext == NO) { + call tp_loadext (extlist, extbuf) + loadext = YES + } + + nc = fnextn (root, Memc[ext], SZ_FNAME) + iext = iki_validextn (0, Memc[ext]) + + if (iext == 0) { + imtype = TP_UNKNOWN + + } else { + call strcpy (Memc[extlist[iext]], Memc[ext], SZ_FNAME) + imtype = strdic (Memc[ext], Memc[ext], SZ_FNAME, TP_EXT_LIST) + } + + call sfree (sp) + return (imtype) +end + +# TP_LOADEXT -- Load list of image kernel names indexed by extension + +procedure tp_loadext (extlist, extbuf) + +pointer extlist[MAXEXT] # o: pointers to kernel names +int extbuf # o: string buffer containing names +#-- +int fd, flags, taglen, iext, ic, jc, nc +pointer sp, line, jstr, kstr + +string kernel_tag "installed kernels " + +int open(), strlen(), getline(), strncmp(), ctoi() + +begin + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Initialize the image kernel tables + + call iki_init () + + # Call the kernel debug routine to dump the information + # about which kernels are associated with which indices + + fd = open ("tp_spool", READ_WRITE, SPOOL_FILE) + call iki_debug ("Kernel Names", fd, flags) + + # Search the file for the line containing the image kernel info + + call seek (fd, BOF) + taglen = strlen (kernel_tag) + + while (getline (fd, Memc[line]) != EOF) { + if (strncmp (Memc[line], kernel_tag, taglen) != 0) + next + + # Parse the line to extract the info + + call malloc (extbuf, strlen (Memc[line+taglen]), TY_CHAR) + jstr = extbuf + kstr = extbuf + + for (ic = taglen; Memc[line+ic] != EOS; ic = ic + 1) { + if (Memc[line+ic] == '=') { + Memc[jstr] = EOS + jstr = jstr + 1 + + jc = 1 + nc = ctoi (Memc[line+ic+1], jc, iext) + ic = ic + 1 + + extlist[iext] = kstr + kstr = jstr + + } else if (! IS_WHITE (Memc[line+ic])) { + Memc[jstr] = Memc[line+ic] + jstr = jstr + 1 + } + } + + break + } + + call close (fd) + call sfree (sp) +end + diff --git a/pkg/utilities/nttools/stxtools/tpopen.x b/pkg/utilities/nttools/stxtools/tpopen.x new file mode 100644 index 00000000..d9b7a2af --- /dev/null +++ b/pkg/utilities/nttools/stxtools/tpopen.x @@ -0,0 +1,38 @@ +include "template.h" + +# TP_OPEN -- Expand a group image template into a list of image names. + +# Create an array of image names that contain the group specification. +# Return a pointer to the list of names and the total number of names. +# +# B.Simon 28-Feb-89 Original +# B.Simon 23-Jun-89 Hint character added +# B.Simon 21-Aug-91 Changed template structure + +pointer procedure tp_open (imname, def_count, count) + +char imname[ARB] # i: image template +int def_count # i: default image name count +int count # o: number of image names +#-- +pointer ptr + +errchk tp_parse, malloc + +begin + # Allocate data structure + + call malloc (ptr, LEN_TPSTRUCT, TY_STRUCT) + call malloc (TP_ROOTPTR(ptr), SZ_FNAME, TY_CHAR) + call malloc (TP_SECTPTR(ptr), SZ_FNAME, TY_CHAR) + + # Parse the template into a root name, starting group number, + # and group count + + call tp_parse (imname, def_count, TP_ROOT(ptr), TP_SECT(ptr), + TP_START(ptr), TP_COUNT(ptr)) + + TP_INDEX(ptr) = TP_START(ptr) + count = TP_COUNT(ptr) + return(ptr) +end diff --git a/pkg/utilities/nttools/stxtools/tpparse.x b/pkg/utilities/nttools/stxtools/tpparse.x new file mode 100644 index 00000000..f261a763 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/tpparse.x @@ -0,0 +1,108 @@ +include + +define NFIELD 4 +define FIELD Memc[($1)+($2-1)*(SZ_FNAME+1)] + +# TP_PARSE -- Parse an image name into its component parts +# +# Parse an image name to obtain the root name, the image section, the +# group index, and the group count. +# +# B.Simon 28-Feb-89 Original +# B.Simon 02-Jun-89 imparse replaced +# B.Simon 16-Jul-98 Revised to flag unparsable sections +# B.Simon 02-Oct-98 added call to tp_count +# B.Simon 26-Apr-99 check for data in extension zero +# B.Simon 06-May-99 set index to one for new files w/o sections +# B.Simon 14-Jun-99 set count to one if section could not be parsed +# B.Simon 20-Nov-00 get default extension with iki_access + +procedure tp_parse (imname, def_count, root, section, index, count) + +char imname[ARB] # i: image name +int def_count # i: default group count +char root[ARB] # o: root name +char section[ARB] # o: image section +int index # o: group index +int count # o: group count +#-- +int ifield, nc +pointer sp, image, root2, sect, ext + +int access(), strlen(), fnextn(), envgets(), iki_access() +int tp_count(), tp_hasgroup() + +string ambiguous " Ambiguous image name, extension required" + +errchk immap, imunmap + +begin + # Allocate dynamic memory for error string + + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (root2, SZ_FNAME, TY_CHAR) + call salloc (sect, (SZ_FNAME+1)*NFIELD, TY_CHAR) + call salloc (ext, SZ_FNAME, TY_CHAR) + + # Break the image name into its component parts and + # get the group index and count + + call tp_break (imname, Memc[sect], NFIELD, SZ_FNAME) + + call tp_group (FIELD(sect,1), FIELD(sect,2), def_count, index, count) + + call strcpy (FIELD(sect,1), root, SZ_FNAME) + call strcpy (FIELD(sect,2), section, SZ_FNAME) + + # Copy the remaining fields into the section + + do ifield = 3, NFIELD + call strcat (FIELD(sect,ifield), section, SZ_FNAME) + + # Add default extension onto image if no extension given + + nc = strlen (root) + if (root[nc] != '.' && fnextn (root, Memc[ext], SZ_FNAME) == 0) { + # Determine the access mode from the default grou[ count + + if (def_count > 0) { + nc = envgets ("imtype", Memc[ext], SZ_FNAME) + + } else { + if (iki_access (root, Memc[root2], + Memc[ext], READ_ONLY) == ERR) + call error (1, ambiguous) + } + + call strcat (".", root, SZ_FNAME) + call strcat (Memc[ext], root, SZ_FNAME) + } + + # Set index and count when the image does not contain a section + + if (section[1] == EOS) { + if (access (root, 0, 0) == NO) { + index = 1 + } else if (tp_hasgroup (root, 1) == YES) { + index = 1 + } else { + index = 0 + } + } + + if (count != ERR) { + count = max (count, 1) + + } else if (index == ERR) { + count = 1 + + } else if (def_count > 0) { + count = def_count + + } else { + count = tp_count (root) + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/stxtools/vex.com b/pkg/utilities/nttools/stxtools/vex.com new file mode 100644 index 00000000..d89b8788 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/vex.com @@ -0,0 +1,11 @@ +# VEX.COM -- Global variables used by vex parsing routine + +pointer line # Buffer containing next line in expression +pointer ch # Pointer to next character in expression +int ncode # Length of code array +int maxcode # Maximum length of code array +pointer code # Pointer to next available code +pointer stack # Pointer to stack structure + +common /vex/ line, ch, ncode, maxcode, code, stack + diff --git a/pkg/utilities/nttools/stxtools/vex.h b/pkg/utilities/nttools/stxtools/vex.h new file mode 100644 index 00000000..200d717c --- /dev/null +++ b/pkg/utilities/nttools/stxtools/vex.h @@ -0,0 +1,107 @@ +# VEX.H -- Structures and constants used by vex + +# Strings + +define FN1STR "abs acos asin atan cos cosh cube double exp int log log10 \ +nint real sin sinh sqr sqrt tan tanh" + +define FN2STR "atan2 dim max min mod sign" + +# Characters + +define BLANK ' ' +define CMTCHAR '#' +define DOLLAR '$' +define DOT '.' + +# Function codes + +define FN1_ABS 1 +define FN1_ACOS 2 +define FN1_ASIN 3 +define FN1_ATAN 4 +define FN1_COS 5 +define FN1_COSH 6 +define FN1_CUBE 7 +define FN1_DOUBLE 8 +define FN1_EXP 9 +define FN1_INT 10 +define FN1_LOG 11 +define FN1_LOG10 12 +define FN1_NINT 13 +define FN1_REAL 14 +define FN1_SIN 15 +define FN1_SINH 16 +define FN1_SQR 17 +define FN1_SQRT 18 +define FN1_TAN 19 +define FN1_TANH 20 + +define FN2_ATAN2 1 +define FN2_DIM 2 +define FN2_MAX 3 +define FN2_MIN 4 +define FN2_MOD 5 +define FN2_SIGN 6 + +# These constants are taken from the output of xyacc run on vexcompile.y + +define Y_WRONG 257 +define Y_LPAR 258 +define Y_RPAR 259 +define Y_COMMA 260 +define Y_VAR 261 +define Y_INT 262 +define Y_REAL 263 +define Y_DOUBLE 264 +define Y_FN1 265 +define Y_FN2 266 +define Y_IF 267 +define Y_THEN 268 +define Y_ELSE 269 +define Y_DONE 270 +define Y_OR 271 +define Y_AND 272 +define Y_NOT 273 +define Y_EQ 274 +define Y_NE 275 +define Y_LT 276 +define Y_GT 277 +define Y_LE 278 +define Y_GE 279 +define Y_ADD 280 +define Y_SUB 281 +define Y_MUL 282 +define Y_DIV 283 +define Y_NEG 284 +define Y_POW 285 + +# Array lengths + +define MAX_TOKEN 31 +define MAX_STACK 64 + +# Pseudocode structure + +define SZ_VEXSTRUCT 2 + +define VEX_CODE Memi[$1] # pointer to code array +define VEX_STACK Memi[$1+1] # pointer to stack structure + +# Stack structure + +define SZ_STKSTRUCT 6 + +define STK_TOP Memi[$1] # top of stack +define STK_HIGH Memi[$1+1] # high water mark in stack +define STK_LENVAL Memi[$1+2] # length of each value array +define STK_NULLARY Memi[$1+3] # pointer to array of null values +define STK_VALARY Memi[$1+4] # pointer to value stack +define STK_TYPARY Memi[$1+5] # pointer to type stack + +define STK_NULL Memb[STK_NULLARY($1)+$2] +define STK_VALUE Memi[STK_VALARY($1)+$2] +define STK_TYPE Memi[STK_TYPARY($1)+$2] + +define TOP -1 # Symbolic constant for top of stack + diff --git a/pkg/utilities/nttools/stxtools/vexcompile.x b/pkg/utilities/nttools/stxtools/vexcompile.x new file mode 100644 index 00000000..c7054b2d --- /dev/null +++ b/pkg/utilities/nttools/stxtools/vexcompile.x @@ -0,0 +1,973 @@ +include +include +include +include "vex.h" + +#* HISTORY * +#* B.Simon ?? original +# Phil Hodge 12-Jul-2005 Add 'int vex_gettok()' and declare 'debug' +# to be bool rather than int, in vex_compile. + +define YYMAXDEPTH 64 +define YYOPLEN 1 +define yyparse vex_parse + +# Tokens generated by xyacc have been moved to vex.h + +define yyclearin yychar = -1 +define yyerrok yyerrflag = 0 +define YYMOVE call amovi (Memi[$1], Memi[$2], YYOPLEN) +define YYERRCODE 256 + +# line 148 "vexcompile.y" + + +# VEX_COMPILE -- Compile an expression, producing pseudocode +# +# This procedure takes a string containing a fortran expression and produces +# pseudocode that can be evaluated by vex_eval(). The pseudocode is stored in +# structure adressed by the pointer returned as the function value. This +# structure is freed by calling vex_free(). If the string begins with an @ +# symbol, the rest of the string is treated as a the name of a file which +# contains the expression. The expression can contain all the fortran +# operators, including logical and relational operators and supports all the +# fortran intrinsic functions which can take real arguments. It also supports +# conditional expressions of the form: if then else +# Variables must follow the fortran rules, and may be up to 31 characters long. +# All variables and constants are treated as real numbers. A variable may +# contain non-alphanumeric characters if it is preceded by a dollar sign, in +# which case all characters until the next blank are part of the variable name. +# +# B.Simon 21-May-90 Original +# B.Simon 19-Apr-91 Revised to handle multiple types +# B.Simon 31-Mar-94 Better syntax error message +# B.Simon 15-Oct-98 Embed strings in pseudocode + +pointer procedure vex_compile (expr) + +char expr[ARB] # i: Expression to be parsed +#-- +include "vex.com" + +int ic, fd, len +bool debug +pointer sp, pcode + +data debug / false / + +int open(), stropen(), strlen(), fstati(), yyparse() + +int vex_gettok() +extern vex_gettok + +begin + # Open the expression as a file + + for (ic = 1; IS_WHITE(expr[ic]); ic = ic + 1) + ; + + if (expr[ic] == '@') { + fd = open (expr[ic+1], READ_ONLY, TEXT_FILE) + len = fstati (fd, F_FILESIZE) + 1 + + } else { + len = strlen (expr[ic]) + 1 + fd = stropen (expr[ic], len, READ_ONLY) + } + + # Create pseudocode structure + + call malloc (pcode, SZ_VEXSTRUCT, TY_STRUCT) + + call malloc (VEX_CODE(pcode), 2 * len, TY_INT) + call stk_init (VEX_STACK(pcode)) + + # Initialize parsing common block + + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + ch = line + Memc[line] = EOS + + ncode = 0 + maxcode = 2 * len + code = VEX_CODE(pcode) + stack = VEX_STACK(pcode) + + # Parse expression to produce reverse polish code + + if (yyparse (fd, debug, vex_gettok) == ERR) { + call eprintf ("%s\n%*t^\n") + call pargstr (Memc[line]) + call pargi (ch-line) + + call error (1, "Syntax error in expression") + } + + # Clean up and return pseudocode structure + + call stk_clear (VEX_STACK(pcode)) + + call close (fd) + call sfree (sp) + return (pcode) +end + +# VEX_GETTOK -- Get the next token from the input + +int procedure vex_gettok (fd, value) + +int fd # i: File containing expression to be lexed +pointer value # o: Address on parse stack to store token +#-- +include "vex.com" + +double constant +int ic, jc, nc, type, index +int idftype[4], keytype[3], btype[9] +pointer sp, errmsg, token + +string fn1tok FN1STR +string fn2tok FN2STR + +string idftok "indefi indefr indefd indef" +data idftype / Y_INT, Y_REAL, Y_DOUBLE, Y_REAL / + +string keytok "if then else" +data keytype / Y_IF, Y_THEN, Y_ELSE / + +string btoken ".or. .and. .eq. .ne. .lt. .gt. .le. .ge. .not." +data btype / Y_OR, Y_AND, Y_EQ, Y_NE, Y_LT, Y_GT, Y_LE, Y_GE, Y_NOT / + +string badsymb "Operator not recognized (%s)" + +int getline(), lexnum(), ctod(), stridxs(), word_match() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + call malloc (token, MAX_TOKEN, TY_CHAR) + + # Skip over leading white space and comments + + while (Memc[ch] <= BLANK || Memc[ch] == CMTCHAR) { + + # If all characters have been read from the current line + # or a comment character was found, get the next line + + if (Memc[ch] == EOS || Memc[ch] == CMTCHAR) { + ch = line + if (getline (fd, Memc[line]) == EOF) { + Memc[ch] = EOS + break + } + } else { + ch = ch + 1 + } + } + + # The token type is determined from the first character in the token + + Memc[token] = EOS + + # End of expression token + + if (Memc[ch] == EOS) { + type = Y_DONE + + # Numeric constant is too difficult to parse, + # Pass the job to lexnum and ctod + + } else if (IS_DIGIT(Memc[ch])) { + + ic = 1 + index = lexnum (Memc[ch], ic, nc) + if (index != LEX_REAL) { + type = Y_INT + } else if (nc > 8) { + type = Y_DOUBLE + } else { + jc = stridxs ("dD", Memc[ch]) + if (jc == 0 || jc > nc) { + type = Y_REAL + } else { + type = Y_DOUBLE + } + } + + ic = 1 + nc = ctod (Memc[ch], ic, constant) + nc = min (nc, MAX_TOKEN) + + call strcpy (Memc[ch], Memc[token], nc) + ch = ch + ic - 1 + + # Token is alphanumeric. Determine what type of token + + } else if (IS_ALPHA (Memc[ch])) { + + # Gather characters in token + + for (ic = 1; ic <= MAX_TOKEN; ic = ic + 1) { + if (Memc[ch] != '_' && ! IS_ALNUM(Memc[ch])) + break + + if (IS_UPPER(Memc[ch])) + Memc[token+ic-1] = TO_LOWER(Memc[ch]) + else + Memc[token+ic-1] = Memc[ch] + ch = ch + 1 + } + Memc[token+ic-1] = EOS + + # Check to see if token is string "INDEF" + + index = word_match (Memc[token], idftok) + + if (index > 0) { + type = idftype[index] + call strupr (Memc[token]) + + } else { + + # Check to see if token is function or keyword name + # If not, add it as a new variable + + index = word_match (Memc[token], fn1tok) + if (index > 0) { + type = Y_FN1 + + } else { + index = word_match (Memc[token], fn2tok) + if (index > 0) { + type = Y_FN2 + + } else { + index = word_match (Memc[token], keytok) + if (index > 0) { + type = keytype[index] + Memc[token] = EOS + } else { + type = Y_VAR + } + } + } + } + + # Tokens beginning with a dot are numbers or boolean operators + + } else if (Memc[ch] == DOT) { + + if (IS_DIGIT (Memc[ch+1])) { + ic = 1 + index = lexnum (Memc[ch], ic, nc) + + if (index != LEX_REAL) { + type = Y_INT + } else if (nc < 9) { + type = Y_REAL + } else { + type = Y_DOUBLE + } + + ic = 1 + nc = ctod (Memc[ch], ic, constant) + nc = min (nc, MAX_TOKEN) + + call strcpy (Memc[ch], Memc[token], nc) + ch = ch + ic - 1 + + } else { + + # Gather characters in token + + ch = ch + 1 + Memc[token] = DOT + for (ic = 2; ic < MAX_TOKEN && Memc[ch] != DOT; ic = ic + 1) { + if (Memc[ch] == EOS) + break + if (IS_UPPER(Memc[ch])) + Memc[token+ic-1] = TO_LOWER(Memc[ch]) + else + Memc[token+ic-1] = Memc[ch] + ch = ch + 1 + } + + Memc[token+ic-1] = Memc[ch] + Memc[token+ic] = EOS + ch = ch + 1 + + index = word_match (Memc[token], btoken) + if (type > 0) { + type = btype[index] + } else { + call sprintf (Memc[errmsg], SZ_LINE, badsymb) + call pargstr (Memc[token]) + call error (1, Memc[errmsg]) + } + } + + # Characters preceded by a dollar sign are identifiers + + } else if (Memc[ch] == DOLLAR) { + + ch = ch + 1 + for (ic = 1; ic <= MAX_TOKEN && Memc[ch] > BLANK; ic = ic + 1) { + if (IS_UPPER(Memc[ch])) + Memc[token+ic-1] = TO_LOWER(Memc[ch]) + else + Memc[token+ic-1] = Memc[ch] + ch = ch + 1 + } + Memc[token+ic-1] = EOS + + type = Y_VAR + + # Anything else is a symbol + + } else { + switch (Memc[ch]) { + case '*': + if (Memc[ch+1] != '*') { + type = Y_MUL + } else { + type = Y_POW + ch = ch + 1 + } + case '/': + type = Y_DIV + case '+': + type = Y_ADD + case '-': + type = Y_SUB + case '(': + type = Y_LPAR + case ')': + type = Y_RPAR + case ',': + type = Y_COMMA + case '<': + if (Memc[ch+1] != '=') { + type = Y_LT + } else { + type = Y_LE + ch = ch + 1 + } + case '>': + if (Memc[ch+1] != '=') { + type = Y_GT + } else { + type = Y_GE + ch = ch + 1 + } + case '|': + if (Memc[ch+1] != '|') { + type = Y_WRONG + } else { + type = Y_OR + ch = ch + 1 + } + case '&': + if (Memc[ch+1] != '&') { + type = Y_WRONG + } else { + type = Y_AND + ch = ch + 1 + } + case '=': + if (Memc[ch+1] != '=') { + type = Y_WRONG + } else { + type = Y_EQ + ch = ch + 1 + } + case '!': + if (Memc[ch+1] != '=') { + type = Y_NOT + } else { + type = Y_NE + ch = ch + 1 + } + default: + Memc[ch+1] = EOS + call sprintf (Memc[errmsg], SZ_LINE, badsymb) + call pargstr (Memc[ch]) + call error (1, Memc[errmsg]) + } + + ch = ch + 1 + } + + # + if (Memc[token] == EOS) { + call mfree (token, TY_CHAR) + token = NULL + } + + Memi[value] = token + return (type) +end + +# VEX_ADDCODE -- Add an instruction to the code array + +procedure vex_addcode (type) + +int type # i: Instruction type +#-- +include "vex.com" + +begin + + if (ncode == maxcode) + call error (1, "Expression too complex") + else { + Memi[code] = type + code = code + 1 + ncode = ncode + 1 + } + +end + +# VEX_ADDSTR -- Embed a string constant in the pseudo-code + +procedure vex_addstr (token) + +pointer token # u: Pointer to token string +#-- +include "vex.com" + +int ic + +begin + if (token == NULL) + call error (1, "Expression token missing") + + if (Memc[token] == EOS) + call error (1, "Expression token blank") + + ic = 0 + repeat { + ic = ic + 1 + + if (ncode == maxcode) + call error (1, "Expression too complex") + else { + Memi[code] = Memc[token+ic-1] + code = code + 1 + ncode = ncode + 1 + } + + } until (Memc[token+ic-1] == EOS) + + call mfree (token, TY_CHAR) +end + +# VEX_GETSTR -- Retrieve a token string from the pseudocode array + +procedure vex_getstr (op, token, maxch) + +pointer op # u: Location of token string in pseudocode +char token[ARB] # o: Token string +int maxch # i: Maximum length of token +#-- +int ic + +begin + # The token begins one position after op and is + # termminated by an EOS + + ic = 0 + repeat { + ic = ic + 1 + op = op + 1 + if (ic <= maxch) + token[ic] = Memi[op] + + } until (Memi[op] == EOS) + +end +define YYNPROD 27 +define YYLAST 264 +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Parser for yacc output, translated to the IRAF SPP language. The contents +# of this file form the bulk of the source of the parser produced by Yacc. +# Yacc recognizes several macros in the yaccpar input source and replaces +# them as follows: +# A user suppled "global" definitions and declarations +# B parser tables +# C user supplied actions (reductions) +# The remainder of the yaccpar code is not changed. + +define yystack_ 10 # statement labels for gotos +define yynewstate_ 20 +define yydefault_ 30 +define yyerrlab_ 40 +define yyabort_ 50 + +define YYFLAG (-1000) # defs used in user actions +define YYERROR goto yyerrlab_ +define YYACCEPT return (OK) +define YYABORT return (ERR) + + +# YYPARSE -- Parse the input stream, returning OK if the source is +# syntactically acceptable (i.e., if compilation is successful), +# otherwise ERR. The parameters YYMAXDEPTH and YYOPLEN must be +# supplied by the caller in the %{ ... %} section of the Yacc source. +# The token value stack is a dynamically allocated array of operand +# structures, with the length and makeup of the operand structure being +# application dependent. + +int procedure yyparse (fd, yydebug, yylex) + +int fd # stream to be parsed +bool yydebug # print debugging information? +int yylex() # user-supplied lexical input function +extern yylex() + +short yys[YYMAXDEPTH] # parser stack -- stacks tokens +pointer yyv # pointer to token value stack +pointer yyval # value returned by action +pointer yylval # value of token +int yyps # token stack pointer +pointer yypv # value stack pointer +int yychar # current input token number +int yyerrflag # error recovery flag +int yynerrs # number of errors + +short yyj, yym # internal variables +pointer yysp, yypvt +short yystate, yyn +int yyxi, i +errchk salloc, yylex + + + +short yyexca[70] +data (yyexca(i),i= 1, 8) / -1, 1, 0, -1, -2, 0, -1, 41/ +data (yyexca(i),i= 9, 16) / 276, 0, 277, 0, 278, 0, 279, 0/ +data (yyexca(i),i= 17, 24) / -2, 18, -1, 42, 276, 0, 277, 0/ +data (yyexca(i),i= 25, 32) / 278, 0, 279, 0, -2, 19, -1, 43/ +data (yyexca(i),i= 33, 40) / 276, 0, 277, 0, 278, 0, 279, 0/ +data (yyexca(i),i= 41, 48) / -2, 20, -1, 44, 276, 0, 277, 0/ +data (yyexca(i),i= 49, 56) / 278, 0, 279, 0, -2, 21, -1, 45/ +data (yyexca(i),i= 57, 64) / 274, 0, 275, 0, -2, 22, -1, 46/ +data (yyexca(i),i= 65, 70) / 274, 0, 275, 0, -2, 23/ +short yyact[264] +data (yyact(i),i= 1, 8) / 58, 22, 23, 24, 25, 20, 21, 18/ +data (yyact(i),i= 9, 16) / 19, 17, 17, 31, 29, 28, 15, 26/ +data (yyact(i),i= 17, 24) / 27, 22, 23, 24, 25, 20, 21, 18/ +data (yyact(i),i= 25, 32) / 19, 55, 17, 29, 28, 30, 26, 27/ +data (yyact(i),i= 33, 40) / 22, 23, 24, 25, 20, 21, 18, 19/ +data (yyact(i),i= 41, 48) / 54, 17, 20, 21, 18, 19, 1, 17/ +data (yyact(i),i= 49, 56) / 0, 0, 0, 29, 28, 0, 26, 27/ +data (yyact(i),i= 57, 64) / 22, 23, 24, 25, 20, 21, 18, 19/ +data (yyact(i),i= 65, 72) / 53, 17, 18, 19, 0, 17, 0, 0/ +data (yyact(i),i= 73, 80) / 0, 0, 2, 0, 29, 28, 0, 26/ +data (yyact(i),i= 81, 88) / 27, 22, 23, 24, 25, 20, 21, 18/ +data (yyact(i),i= 89, 96) / 19, 51, 17, 0, 0, 0, 0, 0/ +data (yyact(i),i= 97,104) / 0, 0, 0, 0, 0, 29, 28, 0/ +data (yyact(i),i=105,112) / 26, 27, 22, 23, 24, 25, 20, 21/ +data (yyact(i),i=113,120) / 18, 19, 35, 17, 0, 29, 28, 0/ +data (yyact(i),i=121,128) / 26, 27, 22, 23, 24, 25, 20, 21/ +data (yyact(i),i=129,136) / 18, 19, 57, 17, 29, 28, 0, 26/ +data (yyact(i),i=137,144) / 27, 22, 23, 24, 25, 20, 21, 18/ +data (yyact(i),i=145,152) / 19, 28, 17, 26, 27, 22, 23, 24/ +data (yyact(i),i=153,160) / 25, 20, 21, 18, 19, 0, 17, 26/ +data (yyact(i),i=161,168) / 27, 22, 23, 24, 25, 20, 21, 18/ +data (yyact(i),i=169,176) / 19, 3, 17, 14, 0, 0, 6, 7/ +data (yyact(i),i=177,184) / 8, 9, 10, 11, 4, 0, 0, 0/ +data (yyact(i),i=185,192) / 14, 0, 13, 6, 7, 8, 9, 10/ +data (yyact(i),i=193,200) / 11, 4, 12, 0, 0, 14, 0, 13/ +data (yyact(i),i=201,208) / 6, 7, 8, 9, 10, 11, 0, 12/ +data (yyact(i),i=209,216) / 5, 0, 0, 0, 13, 16, 0, 0/ +data (yyact(i),i=217,224) / 0, 0, 0, 0, 12, 32, 33, 34/ +data (yyact(i),i=225,232) / 0, 0, 36, 37, 38, 39, 40, 41/ +data (yyact(i),i=233,240) / 42, 43, 44, 45, 46, 47, 48, 49/ +data (yyact(i),i=241,248) / 50, 0, 0, 0, 52, 0, 0, 0/ +data (yyact(i),i=249,256) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=257,264) / 0, 0, 0, 0, 0, 0, 0, 56/ +short yypact[59] +data (yypact(i),i= 1, 8) / -87,-1000,-256,-1000, -61,-139,-1000,-1000/ +data (yypact(i),i= 9, 16) /-1000,-1000,-229,-247, -61, -61, -61,-1000/ +data (yypact(i),i= 17, 24) /-154, -61, -61, -61, -61, -61, -61, -61/ +data (yypact(i),i= 25, 32) / -61, -61, -61, -61, -61, -61, -61, -61/ +data (yypact(i),i= 33, 40) /-276,-115,-170, -61,-276,-276,-276,-216/ +data (yypact(i),i= 41, 48) /-216,-238,-238,-238,-238,-275,-275,-115/ +data (yypact(i),i= 49, 56) /-127,-195,-220,-1000,-244,-1000, -61, -74/ +data (yypact(i),i= 57, 59) /-259,-1000,-1000/ +short yypgo[4] +data (yypgo(i),i= 1, 4) / 0, 46, 74, 208/ +short yyr1[27] +data (yyr1(i),i= 1, 8) / 0, 1, 1, 2, 2, 3, 3, 3/ +data (yyr1(i),i= 9, 16) / 3, 3, 3, 3, 3, 3, 3, 3/ +data (yyr1(i),i= 17, 24) / 3, 3, 3, 3, 3, 3, 3, 3/ +data (yyr1(i),i= 25, 27) / 3, 3, 3/ +short yyr2[27] +data (yyr2(i),i= 1, 8) / 0, 2, 1, 6, 1, 1, 1, 1/ +data (yyr2(i),i= 9, 16) / 1, 4, 6, 2, 2, 3, 3, 3/ +data (yyr2(i),i= 17, 24) / 3, 3, 3, 3, 3, 3, 3, 3/ +data (yyr2(i),i= 25, 27) / 3, 3, 3/ +short yychk[59] +data (yychk(i),i= 1, 8) /-1000, -1, -2, 256, 267, -3, 261, 262/ +data (yychk(i),i= 9, 16) / 263, 264, 265, 266, 281, 273, 258, 270/ +data (yychk(i),i= 17, 24) / -3, 285, 282, 283, 280, 281, 276, 277/ +data (yychk(i),i= 25, 32) / 278, 279, 274, 275, 272, 271, 258, 258/ +data (yychk(i),i= 33, 40) / -3, -3, -3, 268, -3, -3, -3, -3/ +data (yychk(i),i= 41, 48) / -3, -3, -3, -3, -3, -3, -3, -3/ +data (yychk(i),i= 49, 56) / -3, -3, -3, 259, -3, 259, 260, 269/ +data (yychk(i),i= 57, 59) / -3, -2, 259/ +short yydef[59] +data (yydef(i),i= 1, 8) / 0, -2, 0, 2, 0, 4, 5, 6/ +data (yydef(i),i= 9, 16) / 7, 8, 0, 0, 0, 0, 0, 1/ +data (yydef(i),i= 17, 24) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yydef(i),i= 25, 32) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yydef(i),i= 33, 40) / 11, 12, 0, 0, 13, 14, 15, 16/ +data (yydef(i),i= 41, 48) / 17, -2, -2, -2, -2, -2, -2, 24/ +data (yydef(i),i= 49, 56) / 25, 0, 0, 26, 0, 9, 0, 0/ +data (yydef(i),i= 57, 59) / 0, 3, 10/ + +begin + call smark (yysp) + call salloc (yyv, (YYMAXDEPTH+2) * YYOPLEN, TY_STRUCT) + + # Initialization. The first element of the dynamically allocated + # token value stack (yyv) is used for yyval, the second for yylval, + # and the actual stack starts with the third element. + + yystate = 0 + yychar = -1 + yynerrs = 0 + yyerrflag = 0 + yyps = 0 + yyval = yyv + yylval = yyv + YYOPLEN + yypv = yylval + +yystack_ + # SHIFT -- Put a state and value onto the stack. The token and + # value stacks are logically the same stack, implemented as two + # separate arrays. + + if (yydebug) { + call printf ("state %d, char 0%o\n") + call pargs (yystate) + call pargi (yychar) + } + yyps = yyps + 1 + yypv = yypv + YYOPLEN + if (yyps > YYMAXDEPTH) { + call sfree (yysp) + call eprintf ("yacc stack overflow\n") + return (ERR) + } + yys[yyps] = yystate + YYMOVE (yyval, yypv) + +yynewstate_ + # Process the new state. + yyn = yypact[yystate+1] + + if (yyn <= YYFLAG) + goto yydefault_ # simple state + + # The variable "yychar" is the lookahead token. + if (yychar < 0) { + yychar = yylex (fd, yylval) + if (yychar < 0) + yychar = 0 + } + yyn = yyn + yychar + if (yyn < 0 || yyn >= YYLAST) + goto yydefault_ + + yyn = yyact[yyn+1] + if (yychk[yyn+1] == yychar) { # valid shift + yychar = -1 + YYMOVE (yylval, yyval) + yystate = yyn + if (yyerrflag > 0) + yyerrflag = yyerrflag - 1 + goto yystack_ + } + +yydefault_ + # Default state action. + + yyn = yydef[yystate+1] + if (yyn == -2) { + if (yychar < 0) { + yychar = yylex (fd, yylval) + if (yychar < 0) + yychar = 0 + } + + # Look through exception table. + yyxi = 1 + while ((yyexca[yyxi] != (-1)) || (yyexca[yyxi+1] != yystate)) + yyxi = yyxi + 2 + for (yyxi=yyxi+2; yyexca[yyxi] >= 0; yyxi=yyxi+2) { + if (yyexca[yyxi] == yychar) + break + } + + yyn = yyexca[yyxi+1] + if (yyn < 0) { + call sfree (yysp) + return (OK) # ACCEPT -- all done + } + } + + + # SYNTAX ERROR -- resume parsing if possible. + + if (yyn == 0) { + switch (yyerrflag) { + case 0, 1, 2: + if (yyerrflag == 0) { # brand new error + call eprintf ("syntax error\n") +yyerrlab_ + yynerrs = yynerrs + 1 + # fall through... + } + + # case 1: + # case 2: incompletely recovered error ... try again + yyerrflag = 3 + + # Find a state where "error" is a legal shift action. + while (yyps >= 1) { + yyn = yypact[yys[yyps]+1] + YYERRCODE + if ((yyn >= 0) && (yyn < YYLAST) && + (yychk[yyact[yyn+1]+1] == YYERRCODE)) { + # Simulate a shift of "error". + yystate = yyact[yyn+1] + goto yystack_ + } + yyn = yypact[yys[yyps]+1] + + # The current yyps has no shift on "error", pop stack. + if (yydebug) { + call printf ("error recovery pops state %d, ") + call pargs (yys[yyps]) + call printf ("uncovers %d\n") + call pargs (yys[yyps-1]) + } + yyps = yyps - 1 + yypv = yypv - YYOPLEN + } + + # ABORT -- There is no state on the stack with an error shift. +yyabort_ + call sfree (yysp) + return (ERR) + + + case 3: # No shift yet; clobber input char. + + if (yydebug) { + call printf ("error recovery discards char %d\n") + call pargi (yychar) + } + + if (yychar == 0) + goto yyabort_ # don't discard EOF, quit + yychar = -1 + goto yynewstate_ # try again in the same state + } + } + + + # REDUCE -- Reduction by production yyn. + + if (yydebug) { + call printf ("reduce %d\n") + call pargs (yyn) + } + yyps = yyps - yyr2[yyn+1] + yypvt = yypv + yypv = yypv - yyr2[yyn+1] * YYOPLEN + YYMOVE (yypv + YYOPLEN, yyval) + yym = yyn + + # Consult goto table to find next state. + yyn = yyr1[yyn+1] + yyj = yypgo[yyn+1] + yys[yyps] + 1 + if (yyj >= YYLAST) + yystate = yyact[yypgo[yyn+1]+1] + else { + yystate = yyact[yyj+1] + if (yychk[yystate+1] != -yyn) + yystate = yyact[yypgo[yyn+1]+1] + } + + # Perform action associated with the grammar rule, if any. + switch (yym) { + +case 1: +# line 34 "vexcompile.y" +{ + # Normal exit. Code a stop instruction + call vex_addcode (Y_DONE) + return (OK) + } +case 2: +# line 39 "vexcompile.y" +{ + return (ERR) + } +case 3: +# line 44 "vexcompile.y" +{ + # Code an if instruction + call vex_addcode (Y_IF) + } +case 4: +# line 48 "vexcompile.y" +{ + # Null action + } +case 5: +# line 53 "vexcompile.y" +{ + # Code a push variable instruction + call vex_addcode (Y_VAR) + call vex_addstr (Memi[yypvt]) + } +case 6: +# line 58 "vexcompile.y" +{ + # Code a push variable instruction + call vex_addcode (Y_INT) + call vex_addstr (Memi[yypvt]) + } +case 7: +# line 63 "vexcompile.y" +{ + # Code a push variable instruction + call vex_addcode (Y_REAL) + call vex_addstr (Memi[yypvt]) + } +case 8: +# line 68 "vexcompile.y" +{ + # Code a push variable instruction + call vex_addcode (Y_DOUBLE) + call vex_addstr (Memi[yypvt]) + } +case 9: +# line 73 "vexcompile.y" +{ + # Code a single argument function call + call vex_addcode (Y_FN1) + call vex_addstr (Memi[yypvt-3*YYOPLEN]) + } +case 10: +# line 78 "vexcompile.y" +{ + # Code a double argument function call + call vex_addcode (Y_FN2) + call vex_addstr (Memi[yypvt-5*YYOPLEN]) + } +case 11: +# line 83 "vexcompile.y" +{ + # Code a negation instruction + call vex_addcode (Y_NEG) + } +case 12: +# line 87 "vexcompile.y" +{ + # Code a logical not + call vex_addcode (Y_NOT) + } +case 13: +# line 91 "vexcompile.y" +{ + # Code an exponentiation instruction + call vex_addcode (Y_POW) + } +case 14: +# line 95 "vexcompile.y" +{ + # Code a multiply instruction + call vex_addcode (Y_MUL) + } +case 15: +# line 99 "vexcompile.y" +{ + # Code a divide instruction + call vex_addcode (Y_DIV) + } +case 16: +# line 103 "vexcompile.y" +{ + # Code an addition instruction + call vex_addcode (Y_ADD) + } +case 17: +# line 107 "vexcompile.y" +{ + # Code a subtraction instruction + call vex_addcode (Y_SUB) + } +case 18: +# line 111 "vexcompile.y" +{ + # Code a less than instruction + call vex_addcode (Y_LT) + } +case 19: +# line 115 "vexcompile.y" +{ + # Code a greater than instruction + call vex_addcode (Y_GT) + } +case 20: +# line 119 "vexcompile.y" +{ + # Code a less than or equal instruction + call vex_addcode (Y_LE) + } +case 21: +# line 123 "vexcompile.y" +{ + # Code a greater than instruction + call vex_addcode (Y_GE) + } +case 22: +# line 127 "vexcompile.y" +{ + # Code a logical equality instruction + call vex_addcode (Y_EQ) + } +case 23: +# line 131 "vexcompile.y" +{ + # Code a logical inequality instruction + call vex_addcode (Y_NE) + } +case 24: +# line 135 "vexcompile.y" +{ + # Code a logical and instruction + call vex_addcode (Y_AND) + } +case 25: +# line 139 "vexcompile.y" +{ + # Code a logical or instruction + call vex_addcode (Y_OR) + } +case 26: +# line 143 "vexcompile.y" +{ + # Null action + } } + + goto yystack_ # stack new state and value +end diff --git a/pkg/utilities/nttools/stxtools/vexcompile.y b/pkg/utilities/nttools/stxtools/vexcompile.y new file mode 100644 index 00000000..4b2cd958 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/vexcompile.y @@ -0,0 +1,616 @@ +%{ + +include +include +include +include "vex.h" + +define YYMAXDEPTH 64 +define YYOPLEN 1 +define yyparse vex_parse + +# Tokens generated by xyacc have been moved to vex.h + +%L + +%} + +%token Y_WRONG Y_LPAR Y_RPAR Y_COMMA +%token Y_VAR Y_INT Y_REAL Y_DOUBLE +%token Y_FN1 Y_FN2 Y_IF Y_THEN Y_ELSE Y_DONE + +%left Y_OR +%left Y_AND +%right Y_NOT +%nonassoc Y_EQ Y_NE +%nonassoc Y_LT Y_GT Y_LE Y_GE +%left Y_ADD Y_SUB +%left Y_MUL Y_DIV +%right Y_NEG +%right Y_POW + +%% + +stmt : ifexpr Y_DONE { + # Normal exit. Code a stop instruction + call vex_addcode (Y_DONE) + return (OK) + } + | error { + return (ERR) + } + ; + +ifexpr : Y_IF expr Y_THEN expr Y_ELSE ifexpr { + # Code an if instruction + call vex_addcode (Y_IF) + } + | expr { + # Null action + } + ; + +expr : Y_VAR { + # Code a push variable instruction + call vex_addcode (Y_VAR) + call vex_addstr (Memi[$1]) + } + | Y_INT { + # Code a push variable instruction + call vex_addcode (Y_INT) + call vex_addstr (Memi[$1]) + } + | Y_REAL { + # Code a push variable instruction + call vex_addcode (Y_REAL) + call vex_addstr (Memi[$1]) + } + | Y_DOUBLE { + # Code a push variable instruction + call vex_addcode (Y_DOUBLE) + call vex_addstr (Memi[$1]) + } + | Y_FN1 Y_LPAR expr Y_RPAR { + # Code a single argument function call + call vex_addcode (Y_FN1) + call vex_addstr (Memi[$1]) + } + | Y_FN2 Y_LPAR expr Y_COMMA expr Y_RPAR { + # Code a double argument function call + call vex_addcode (Y_FN2) + call vex_addstr (Memi[$1]) + } + | Y_SUB expr %prec Y_NEG { + # Code a negation instruction + call vex_addcode (Y_NEG) + } + | Y_NOT expr { + # Code a logical not + call vex_addcode (Y_NOT) + } + | expr Y_POW expr { + # Code an exponentiation instruction + call vex_addcode (Y_POW) + } + | expr Y_MUL expr { + # Code a multiply instruction + call vex_addcode (Y_MUL) + } + | expr Y_DIV expr { + # Code a divide instruction + call vex_addcode (Y_DIV) + } + | expr Y_ADD expr { + # Code an addition instruction + call vex_addcode (Y_ADD) + } + | expr Y_SUB expr { + # Code a subtraction instruction + call vex_addcode (Y_SUB) + } + | expr Y_LT expr { + # Code a less than instruction + call vex_addcode (Y_LT) + } + | expr Y_GT expr { + # Code a greater than instruction + call vex_addcode (Y_GT) + } + | expr Y_LE expr { + # Code a less than or equal instruction + call vex_addcode (Y_LE) + } + | expr Y_GE expr { + # Code a greater than instruction + call vex_addcode (Y_GE) + } + | expr Y_EQ expr { + # Code a logical equality instruction + call vex_addcode (Y_EQ) + } + | expr Y_NE expr { + # Code a logical inequality instruction + call vex_addcode (Y_NE) + } + | expr Y_AND expr { + # Code a logical and instruction + call vex_addcode (Y_AND) + } + | expr Y_OR expr { + # Code a logical or instruction + call vex_addcode (Y_OR) + } + | Y_LPAR expr Y_RPAR { + # Null action + } + ; + +%% + +# VEX_COMPILE -- Compile an expression, producing pseudocode +# +# This procedure takes a string containing a fortran expression and produces +# pseudocode that can be evaluated by vex_eval(). The pseudocode is stored in +# structure adressed by the pointer returned as the function value. This +# structure is freed by calling vex_free(). If the string begins with an @ +# symbol, the rest of the string is treated as a the name of a file which +# contains the expression. The expression can contain all the fortran +# operators, including logical and relational operators and supports all the +# fortran intrinsic functions which can take real arguments. It also supports +# conditional expressions of the form: if then else +# Variables must follow the fortran rules, and may be up to 31 characters long. +# All variables and constants are treated as real numbers. A variable may +# contain non-alphanumeric characters if it is preceded by a dollar sign, in +# which case all characters until the next blank are part of the variable name. +# +# B.Simon 21-May-90 Original +# B.Simon 19-Apr-91 Revised to handle multiple types +# B.Simon 31-Mar-94 Better syntax error message +# B.Simon 15-Oct-98 Embed strings in pseudocode + +pointer procedure vex_compile (expr) + +char expr[ARB] # i: Expression to be parsed +#-- +include "vex.com" + +int ic, fd, len +bool debug +pointer sp, pcode + +data debug / false / + +int open(), stropen(), strlen(), fstati(), yyparse() + +int vex_gettok () +extern vex_gettok + +begin + # Open the expression as a file + + for (ic = 1; IS_WHITE(expr[ic]); ic = ic + 1) + ; + + if (expr[ic] == '@') { + fd = open (expr[ic+1], READ_ONLY, TEXT_FILE) + len = fstati (fd, F_FILESIZE) + 1 + + } else { + len = strlen (expr[ic]) + 1 + fd = stropen (expr[ic], len, READ_ONLY) + } + + # Create pseudocode structure + + call malloc (pcode, SZ_VEXSTRUCT, TY_STRUCT) + + call malloc (VEX_CODE(pcode), 2 * len, TY_INT) + call stk_init (VEX_STACK(pcode)) + + # Initialize parsing common block + + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + ch = line + Memc[line] = EOS + + ncode = 0 + maxcode = 2 * len + code = VEX_CODE(pcode) + stack = VEX_STACK(pcode) + + # Parse expression to produce reverse polish code + + if (yyparse (fd, debug, vex_gettok) == ERR) { + call eprintf ("%s\n%*t^\n") + call pargstr (Memc[line]) + call pargi (ch-line) + + call error (1, "Syntax error in expression") + } + + # Clean up and return pseudocode structure + + call stk_clear (VEX_STACK(pcode)) + + call close (fd) + call sfree (sp) + return (pcode) +end + +# VEX_GETTOK -- Get the next token from the input + +int procedure vex_gettok (fd, value) + +int fd # i: File containing expression to be lexed +pointer value # o: Address on parse stack to store token +#-- +include "vex.com" + +double constant +int ic, jc, nc, type, index +int idftype[4], keytype[3], btype[9] +pointer sp, errmsg, token + +string fn1tok FN1STR +string fn2tok FN2STR + +string idftok "indefi indefr indefd indef" +data idftype / Y_INT, Y_REAL, Y_DOUBLE, Y_REAL / + +string keytok "if then else" +data keytype / Y_IF, Y_THEN, Y_ELSE / + +string btoken ".or. .and. .eq. .ne. .lt. .gt. .le. .ge. .not." +data btype / Y_OR, Y_AND, Y_EQ, Y_NE, Y_LT, Y_GT, Y_LE, Y_GE, Y_NOT / + +string badsymb "Operator not recognized (%s)" + +int getline(), lexnum(), ctod(), stridxs(), word_match() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + call malloc (token, MAX_TOKEN, TY_CHAR) + + # Skip over leading white space and comments + + while (Memc[ch] <= BLANK || Memc[ch] == CMTCHAR) { + + # If all characters have been read from the current line + # or a comment character was found, get the next line + + if (Memc[ch] == EOS || Memc[ch] == CMTCHAR) { + ch = line + if (getline (fd, Memc[line]) == EOF) { + Memc[ch] = EOS + break + } + } else { + ch = ch + 1 + } + } + + # The token type is determined from the first character in the token + + Memc[token] = EOS + + # End of expression token + + if (Memc[ch] == EOS) { + type = Y_DONE + + # Numeric constant is too difficult to parse, + # Pass the job to lexnum and ctod + + } else if (IS_DIGIT(Memc[ch])) { + + ic = 1 + index = lexnum (Memc[ch], ic, nc) + if (index != LEX_REAL) { + type = Y_INT + } else if (nc > 8) { + type = Y_DOUBLE + } else { + jc = stridxs ("dD", Memc[ch]) + if (jc == 0 || jc > nc) { + type = Y_REAL + } else { + type = Y_DOUBLE + } + } + + ic = 1 + nc = ctod (Memc[ch], ic, constant) + nc = min (nc, MAX_TOKEN) + + call strcpy (Memc[ch], Memc[token], nc) + ch = ch + ic - 1 + + # Token is alphanumeric. Determine what type of token + + } else if (IS_ALPHA (Memc[ch])) { + + # Gather characters in token + + for (ic = 1; ic <= MAX_TOKEN; ic = ic + 1) { + if (Memc[ch] != '_' && ! IS_ALNUM(Memc[ch])) + break + + if (IS_UPPER(Memc[ch])) + Memc[token+ic-1] = TO_LOWER(Memc[ch]) + else + Memc[token+ic-1] = Memc[ch] + ch = ch + 1 + } + Memc[token+ic-1] = EOS + + # Check to see if token is string "INDEF" + + index = word_match (Memc[token], idftok) + + if (index > 0) { + type = idftype[index] + call strupr (Memc[token]) + + } else { + + # Check to see if token is function or keyword name + # If not, add it as a new variable + + index = word_match (Memc[token], fn1tok) + if (index > 0) { + type = Y_FN1 + + } else { + index = word_match (Memc[token], fn2tok) + if (index > 0) { + type = Y_FN2 + + } else { + index = word_match (Memc[token], keytok) + if (index > 0) { + type = keytype[index] + Memc[token] = EOS + } else { + type = Y_VAR + } + } + } + } + + # Tokens beginning with a dot are numbers or boolean operators + + } else if (Memc[ch] == DOT) { + + if (IS_DIGIT (Memc[ch+1])) { + ic = 1 + index = lexnum (Memc[ch], ic, nc) + + if (index != LEX_REAL) { + type = Y_INT + } else if (nc < 9) { + type = Y_REAL + } else { + type = Y_DOUBLE + } + + ic = 1 + nc = ctod (Memc[ch], ic, constant) + nc = min (nc, MAX_TOKEN) + + call strcpy (Memc[ch], Memc[token], nc) + ch = ch + ic - 1 + + } else { + + # Gather characters in token + + ch = ch + 1 + Memc[token] = DOT + for (ic = 2; ic < MAX_TOKEN && Memc[ch] != DOT; ic = ic + 1) { + if (Memc[ch] == EOS) + break + if (IS_UPPER(Memc[ch])) + Memc[token+ic-1] = TO_LOWER(Memc[ch]) + else + Memc[token+ic-1] = Memc[ch] + ch = ch + 1 + } + + Memc[token+ic-1] = Memc[ch] + Memc[token+ic] = EOS + ch = ch + 1 + + index = word_match (Memc[token], btoken) + if (type > 0) { + type = btype[index] + } else { + call sprintf (Memc[errmsg], SZ_LINE, badsymb) + call pargstr (Memc[token]) + call error (1, Memc[errmsg]) + } + } + + # Characters preceded by a dollar sign are identifiers + + } else if (Memc[ch] == DOLLAR) { + + ch = ch + 1 + for (ic = 1; ic <= MAX_TOKEN && Memc[ch] > BLANK; ic = ic + 1) { + if (IS_UPPER(Memc[ch])) + Memc[token+ic-1] = TO_LOWER(Memc[ch]) + else + Memc[token+ic-1] = Memc[ch] + ch = ch + 1 + } + Memc[token+ic-1] = EOS + + type = Y_VAR + + # Anything else is a symbol + + } else { + switch (Memc[ch]) { + case '*': + if (Memc[ch+1] != '*') { + type = Y_MUL + } else { + type = Y_POW + ch = ch + 1 + } + case '/': + type = Y_DIV + case '+': + type = Y_ADD + case '-': + type = Y_SUB + case '(': + type = Y_LPAR + case ')': + type = Y_RPAR + case ',': + type = Y_COMMA + case '<': + if (Memc[ch+1] != '=') { + type = Y_LT + } else { + type = Y_LE + ch = ch + 1 + } + case '>': + if (Memc[ch+1] != '=') { + type = Y_GT + } else { + type = Y_GE + ch = ch + 1 + } + case '|': + if (Memc[ch+1] != '|') { + type = Y_WRONG + } else { + type = Y_OR + ch = ch + 1 + } + case '&': + if (Memc[ch+1] != '&') { + type = Y_WRONG + } else { + type = Y_AND + ch = ch + 1 + } + case '=': + if (Memc[ch+1] != '=') { + type = Y_WRONG + } else { + type = Y_EQ + ch = ch + 1 + } + case '!': + if (Memc[ch+1] != '=') { + type = Y_NOT + } else { + type = Y_NE + ch = ch + 1 + } + default: + Memc[ch+1] = EOS + call sprintf (Memc[errmsg], SZ_LINE, badsymb) + call pargstr (Memc[ch]) + call error (1, Memc[errmsg]) + } + + ch = ch + 1 + } + + # + if (Memc[token] == EOS) { + call mfree (token, TY_CHAR) + token = NULL + } + + Memi[value] = token + return (type) +end + +# VEX_ADDCODE -- Add an instruction to the code array + +procedure vex_addcode (type) + +int type # i: Instruction type +#-- +include "vex.com" + +begin + + if (ncode == maxcode) + call error (1, "Expression too complex") + else { + Memi[code] = type + code = code + 1 + ncode = ncode + 1 + } + +end + +# VEX_ADDSTR -- Embed a string constant in the pseudo-code + +procedure vex_addstr (token) + +pointer token # u: Pointer to token string +#-- +include "vex.com" + +int ic + +begin + if (token == NULL) + call error (1, "Expression token missing") + + if (Memc[token] == EOS) + call error (1, "Expression token blank") + + ic = 0 + repeat { + ic = ic + 1 + + if (ncode == maxcode) + call error (1, "Expression too complex") + else { + Memi[code] = Memc[token+ic-1] + code = code + 1 + ncode = ncode + 1 + } + + } until (Memc[token+ic-1] == EOS) + + call mfree (token, TY_CHAR) +end + +# VEX_GETSTR -- Retrieve a token string from the pseudocode array + +procedure vex_getstr (op, token, maxch) + +pointer op # u: Location of token string in pseudocode +char token[ARB] # o: Token string +int maxch # i: Maximum length of token +#-- +int ic + +begin + # The token begins one position after op and is + # termminated by an EOS + + ic = 0 + repeat { + ic = ic + 1 + op = op + 1 + if (ic <= maxch) + token[ic] = Memi[op] + + } until (Memi[op] == EOS) + +end diff --git a/pkg/utilities/nttools/stxtools/vexeval.x b/pkg/utilities/nttools/stxtools/vexeval.x new file mode 100644 index 00000000..40b10fbd --- /dev/null +++ b/pkg/utilities/nttools/stxtools/vexeval.x @@ -0,0 +1,228 @@ +include "vex.h" + +# VEX_EVAL -- Evaluate the pseudocode +# +# This procedure evaluates the pseudocode produced by vex_compile(). Evaluation +# is performed on an entire vector at a time. The calling program must +# supply a subroutine which returns the vector associated with a variable name. +# The procedure is called as follows: call getvar(stack, name), where +# stack is a pointer to the stack structure and name is the variable name. +# This procedure should call stk_alloc(stack, len, type) passing it the stack +# pointer, the length of the new array, and the type of the new array. The +# pointer to the new array is returned as the function value. The procedure +# should then fill in the values in the array. Code is the pointer returned +# by vex_compile(). Nil is a value substituted for the result of an illegal +# operation, such as division by zero. Type is the data type of expression. +# To retrieve the results of the expression, call vex_copy[dir], which +# retrieves the result as a double, integer, or real array and clears the +# stack for the next call of vex_eval. +# +# B.Simon 21-May-90 Original +# B.Simon 24-Apr-91 Revised to handle multiple types +# B.Simon 15-Oct-98 Embed strings in pseudocode + +procedure vex_eval (code, getvar, nil, type) + +pointer code # i: Pointer to pseudocode structure +extern getvar # i: Function which returns a vector given a name +double nil # i: Nil value used to replace illegal ops +int type # o: Data type of expression +#-- +double junk +int len, toktype +pointer sp, token, errmsg, stack, op, var + +string fn1tok FN1STR +string fn2tok FN2STR + +int word_match +double vex_nilf() +errchk vex_push + +string badcode "vex_eval : Illegal opcode (%d)" +string badfunc "vex_eval : Illegal function name (%s)" + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (token, MAX_TOKEN, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Initialize the undefined operation function + + junk = vex_nilf (nil) + + # Execute each code token until stop token found + + stack = VEX_STACK(code) + for (op = VEX_CODE(code); Memi[op] != Y_DONE; op = op + 1) { + call pargi (Memi[op]) + + # Perform the indicated operation on the stack variables + + switch (Memi[op]) { + case Y_VAR, Y_INT, Y_REAL, Y_DOUBLE: + toktype = Memi[op] + call vex_getstr (op, Memc[token], MAX_TOKEN) + call vex_push (stack, getvar, toktype, Memc[token]) + + case Y_FN1: + call vex_getstr (op, Memc[token], MAX_TOKEN) + + switch (word_match (Memc[token], fn1tok)) { + case FN1_ABS: + call vex_abs (stack) + + case FN1_ACOS: + call vex_acos (stack) + + case FN1_ASIN: + call vex_asin (stack) + + case FN1_ATAN: + call vex_atan (stack) + + case FN1_COS: + call vex_cos (stack) + + case FN1_COSH: + call vex_cosh (stack) + + case FN1_CUBE: + call vex_cube (stack) + + case FN1_DOUBLE: + call vex_double (stack) + + case FN1_EXP: + call vex_exp (stack) + + case FN1_INT: + call vex_int (stack) + + case FN1_LOG: + call vex_log (stack) + + case FN1_LOG10: + call vex_log10 (stack) + + case FN1_NINT: + call vex_nint (stack) + + case FN1_REAL: + call vex_real (stack) + + case FN1_SIN: + call vex_sin (stack) + + case FN1_SINH: + call vex_sinh (stack) + + case FN1_SQR: + call vex_sqr (stack) + + case FN1_SQRT: + call vex_sqrt (stack) + + case FN1_TAN: + call vex_tan (stack) + + case FN1_TANH: + call vex_tanh (stack) + + default: + call sprintf (Memc[errmsg], SZ_LINE, badfunc) + call pargstr (Memc[token]) + call error (1, Memc[errmsg]) + } + + case Y_FN2: + call vex_getstr (op, Memc[token], MAX_TOKEN) + + switch (word_match (Memc[token], fn2tok)) { + case FN2_ATAN2: + call vex_atan2 (stack) + + case FN2_DIM: + call vex_dim (stack) + + case FN2_MAX: + call vex_max (stack) + + case FN2_MIN: + call vex_min (stack) + + case FN2_MOD: + call vex_mod (stack) + + case FN2_SIGN: + call vex_sig (stack) + + default: + call sprintf (Memc[errmsg], SZ_LINE, badfunc) + call pargstr (Memc[token]) + call error (1, Memc[errmsg]) + } + + case Y_IF: + call vex_if (stack) + + case Y_OR: + call vex_or (stack) + + case Y_AND: + call vex_and (stack) + + case Y_NOT: + call vex_not (stack) + + case Y_EQ: + call vex_eq (stack) + + case Y_NE: + call vex_ne (stack) + + case Y_LT: + call vex_lt (stack) + + case Y_GT: + call vex_gt (stack) + + case Y_LE: + call vex_le (stack) + + case Y_GE: + call vex_ge (stack) + + case Y_ADD: + call vex_add (stack) + + case Y_SUB: + call vex_sub (stack) + + case Y_MUL: + call vex_mul (stack) + + case Y_DIV: + call vex_div (stack) + + case Y_NEG: + call vex_neg (stack) + + case Y_POW: + call vex_pow (stack) + + default: + call sprintf (Memc[errmsg], SZ_LINE, badcode) + call pargs (Memi[op]) + call error (1, Memc[errmsg]) + } + } + + # Retrieve the result of the expression, + # but only return the type to the user + + call stk_fetch (stack, 1, var, len, type) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/stxtools/vexfree.x b/pkg/utilities/nttools/stxtools/vexfree.x new file mode 100644 index 00000000..f98bee57 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/vexfree.x @@ -0,0 +1,22 @@ +include "vex.h" + +# VEX_FREE -- Free the pseudocode structure +# +# This procedure frees the structure created by vex_compile() and evaluated +# by vex_eval() +# +# B.Simon 21-May-90 Original +# B.Simon 19-Apr-91 Revised to handle multiple types + +procedure vex_free (code) + +pointer code # i: Pointer to pseudocode structure +#-- + +begin + call stk_free (VEX_STACK(code)) + + call mfree (VEX_CODE(code), TY_INT) + call mfree (code, TY_STRUCT) +end + diff --git a/pkg/utilities/nttools/stxtools/vexfunc.x b/pkg/utilities/nttools/stxtools/vexfunc.x new file mode 100644 index 00000000..b4e40ae6 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/vexfunc.x @@ -0,0 +1,2011 @@ +include +include "vex.h" + +define MAX_EXP (2.3 * MAX_EXPONENT) +define MIN_REAL 1.0e-20 +define MIN_DOUBLE 1.0d-20 + +# VEX_FUNC -- Miscelaneous procedures used by the vex expression evaluator. +# +# Mostly these functions implement single opcodes such as add, sin, and +# push. However, it also includes vex_copy[dir], which copies the array +# on the top of the stack into a user array and vex_errf, which returns +# the substitute value used when an opcode would return an undefined +# value. The only functions which should be called directly from a user's +# program are vex_copy[dir]. +# +# B.Simon 24-Apr-91 Original +# B.Simon 15-Oct-98 Rewrite vex_push to use embedded strings + +# VEX_ABS -- Absolute value function + +procedure vex_abs (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = abs (Memi[in+i]) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = abs (Memr[in+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = abs (Memd[in+i]) + + } + + call stk_pop (stack, 1) +end + +# VEX_ACOS -- Arc cosine function + +procedure vex_acos (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] < -1 || Memi[in+i] > 1) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = acos (real (Memi[in+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] < -1.0 || Memr[in+i] > 1.0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = acos (Memr[in+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] < -1.0 || Memd[in+i] > 1.0) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = acos (Memd[in+i]) + } + } + + } + + call stk_pop (stack, 1) +end + +# VEX_ADD -- Addition function + +procedure vex_add (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = Memi[in[1]+i] + Memi[in[2]+i] + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = Memr[in[1]+i] + Memr[in[2]+i] + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = Memd[in[1]+i] + Memd[in[2]+i] + + } + + call stk_pop (stack, 2) +end + +# VEX_AND -- Logical and + +procedure vex_and (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] != 0 && Memi[in[2]+i] != 0) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] != 0.0 && Memr[in[2]+i] != 0.0) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] != 0.0 && Memd[in[2]+i] != 0.0) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_ASIN -- Arc sine function + +procedure vex_asin (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] < -1 || Memi[in+i] > 1) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = asin (real (Memi[in+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] < -1.0 || Memr[in+i] > 1.0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = asin (Memr[in+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] < -1.0 || Memd[in+i] > 1.0) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = asin (Memd[in+i]) + } + } + + } + + call stk_pop (stack, 1) +end + +# VEX_ATAN -- Arc tangent function with one argument + +procedure vex_atan (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memr[out+i] = atan (real (Memi[in+i])) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = atan (Memr[in+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = atan (Memd[in+i]) + + } + + call stk_pop (stack, 1) +end + +# VEX_ATAN2 -- Arc tangent function with two arguments + +procedure vex_atan2 (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] == 0 && Memi[in[2]+i] == 0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = atan2 (real (Memi[in[1]+i]), + real (Memi[in[2]+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] == 0.0 && Memr[in[2]+i] == 0.0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = atan2 (Memr[in[1]+i], Memr[in[2]+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] == 0.0 && Memd[in[2]+i] == 0.0) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = atan2 (Memd[in[1]+i], Memd[in[2]+i]) + } + } + + } + + call stk_pop (stack, 2) +end + +# VEX_COPYD -- Copy the top element of the stack into a double array + +procedure vex_copyd (code, nullval, buffer, maxbuf) + +pointer code # i: Pseudocode structure pointer +double nullval # i: Value to substitute for nulls +double buffer[ARB] # o: Output array +int maxbuf # i: Length of buffer +#-- +int len, type, ibuf +pointer stack, var, nullbuf + +string badsize "Cannot copy more elements than stack contains" + +begin + stack = VEX_STACK(code) + call stk_get (stack, TOP, var, len, type) + + if (type != TY_DOUBLE) + call stk_coerce (stack, TOP, TY_DOUBLE, var) + + if (maxbuf <= len) { + do ibuf = 1, maxbuf { + buffer[ibuf] = Memd[var] + var = var + 1 + } + + } else if (len != 0) { + call error (1, badsize) + + } else { + do ibuf = 1, maxbuf + buffer[ibuf] = Memd[var] + } + + # Set the null value in the output array + + call stk_getnull (stack, nullbuf) + if (nullbuf != NULL) { + do ibuf = 1, maxbuf { + if (Memb[nullbuf]) + buffer[ibuf] = nullval + if (len > 0) + nullbuf = nullbuf + 1 + } + } + + call stk_clear (stack) +end + +# VEX_COPYI -- Copy the top element of the stack into an integer array + +procedure vex_copyi (code, nullval, buffer, maxbuf) + +pointer code # i: Pseudocode structure pointer +int nullval # i: Value to substitute for nulls +int buffer[ARB] # o: Output array +int maxbuf # i: Length of buffer +#-- +int len, type, ibuf +pointer stack, var, nullbuf + +string badsize "Cannot copy more elements than stack contains" + +begin + stack = VEX_STACK(code) + call stk_get (stack, TOP, var, len, type) + + if (type != TY_INT) + call stk_coerce (stack, TOP, TY_INT, var) + + if (maxbuf <= len) { + do ibuf = 1, maxbuf { + buffer[ibuf] = Memi[var] + var = var + 1 + } + + } else if (len != 0) { + call error (1, badsize) + + } else { + do ibuf = 1, maxbuf + buffer[ibuf] = Memi[var] + } + + # Set the null value in the output array + + call stk_getnull (stack, nullbuf) + if (nullbuf != NULL) { + do ibuf = 1, maxbuf { + if (Memb[nullbuf]) + buffer[ibuf] = nullval + if (len > 0) + nullbuf = nullbuf + 1 + } + } + + call stk_clear (stack) +end + +# VEX_COPYR -- Copy the top element of the stack into a real array + +procedure vex_copyr (code, nullval, buffer, maxbuf) + +pointer code # i: Pseudocode structure pointer +real nullval # i: Value to substitute for nulls +real buffer[ARB] # o: Output array +int maxbuf # i: Length of buffer +#-- +int len, type, ibuf +pointer stack, var, nullbuf + +string badsize "Cannot copy more elements than stack contains" + +begin + stack = VEX_STACK(code) + call stk_get (stack, TOP, var, len, type) + + if (type != TY_REAL) + call stk_coerce (stack, TOP, TY_REAL, var) + + if (maxbuf <= len) { + do ibuf = 1, maxbuf { + buffer[ibuf] = Memr[var] + var = var + 1 + } + + } else if (len != 0) { + call error (1, badsize) + + } else { + do ibuf = 1, maxbuf + buffer[ibuf] = Memr[var] + } + + # Set the null value in the output array + + call stk_getnull (stack, nullbuf) + if (nullbuf != NULL) { + do ibuf = 1, maxbuf { + if (Memb[nullbuf]) + buffer[ibuf] = nullval + if (len > 0) + nullbuf = nullbuf + 1 + } + } + + call stk_clear (stack) +end + +# VEX_COS -- Cosine function + +procedure vex_cos (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memr[out+i] = cos (real (Memi[in+i])) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = cos (Memr[in+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = cos (Memd[in+i]) + + } + + call stk_pop (stack, 1) +end + +# VEX_COSH -- Hyperbolic cosine function + +procedure vex_cosh (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] > MAX_EXP) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = cosh (real (Memi[in+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] > MAX_EXP) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = cosh (Memr[in+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] > MAX_EXP) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = cosh (Memd[in+i]) + } + } + } + + call stk_pop (stack, 1) +end + +# VEX_CUBE -- Third power + +procedure vex_cube (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = Memi[in+i] * Memi[in+i] * Memi[in+i] + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = Memr[in+i] * Memr[in+i] * Memr[in+i] + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = Memd[in+i] * Memd[in+i] * Memd[in+i] + + } + + call stk_pop (stack, 1) +end + +# VEX_DIM -- Positive difference + +procedure vex_dim (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = dim (Memi[in[1]+i], Memi[in[2]+i]) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = dim (Memr[in[1]+i], Memr[in[2]+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = dim (Memd[in[1]+i], Memd[in[2]+i]) + + } + + call stk_pop (stack, 2) +end + +# VEX_DIV -- Division function + +procedure vex_div (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[2]+i] == 0) { + Memi[out+i] = vex_errf (stack, i) + } else { + Memi[out+i] = Memi[in[1]+i] / Memi[in[2]+i] + } + } + case TY_REAL: + do i = 0, len-1 { + if (abs(Memr[in[2]+i]) < MIN_REAL) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = Memr[in[1]+i] / Memr[in[2]+i] + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (abs(Memd[in[2]+i]) < MIN_DOUBLE) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = Memd[in[1]+i] / Memd[in[2]+i] + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_DOUBLE -- Convert to double + +procedure vex_double (stack) + +pointer stack # u: Stack descriptor +#-- +pointer out + +begin + call stk_coerce (stack, TOP, TY_DOUBLE, out) + +end + +# VEX_EQ -- Logical equality + +procedure vex_eq (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] == Memi[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] == Memr[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] == Memd[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_ERRF -- Called when a function cannot be evaluated + +double procedure vex_errf (stack, index) + +pointer stack # u: Stack descriptor +int index # i: Index to row with illegal operation +double nil # i: Value substituted for illegal operation +#-- +double substitute +double temp + +data substitute / 0.0 / + +double vex_nilf() + +begin + call stk_initnull (stack, false) + call stk_setnull (stack, index) + + return (substitute) + + entry vex_nilf (nil) + + temp = substitute + substitute = nil + return (temp) + +end + +# VEX_EXP -- Exponentiation function + +procedure vex_exp (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] > MAX_EXP) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = exp (real (Memi[in+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] > MAX_EXP) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = exp (Memr[in+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] > MAX_EXP) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = exp (Memd[in+i]) + } + } + + } + + call stk_pop (stack, 1) +end + +# VEX_GE -- Greater than or equal to function + +procedure vex_ge (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] >= Memi[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] >= Memr[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] >= Memd[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_GT -- Greater than function + +procedure vex_gt (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] > Memi[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] > Memr[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] > Memd[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_IF -- Conditional evaluation + +procedure vex_if (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, index, i +pointer out, in[3] + +int stk_pos() +pointer stk_alloc() + +begin + call stk_fetch (stack, 3, in, len, type) + index = stk_pos (stack, 3) + call stk_coerce (stack, index, TY_INT, in[1]) + + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] != 0) { + Memi[out+i] = Memi[in[2]+i] + } else { + Memi[out+i] = Memi[in[3]+i] + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memi[in[1]+i] != 0) { + Memr[out+i] = Memr[in[2]+i] + } else { + Memr[out+i] = Memr[in[3]+i] + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memi[in[1]+i] != 0) { + Memd[out+i] = Memd[in[2]+i] + } else { + Memd[out+i] = Memd[in[3]+i] + } + } + } + + call stk_pop (stack, 3) +end + +# VEX_INT -- Convert to integer + +procedure vex_int (stack) + +pointer stack # u: Stack descriptor +#-- +pointer out + +begin + call stk_coerce (stack, TOP, TY_INT, out) + +end + +# VEX_LE -- Less than or equal to function + +procedure vex_le (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] <= Memi[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] <= Memr[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] <= Memd[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_LT -- Less than function + +procedure vex_lt (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] < Memi[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] < Memr[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] < Memd[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_LOG -- Natural log function + +procedure vex_log (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] <= 0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = log (real (Memi[in+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] <= 0.0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = log (Memr[in+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] <= 0.0) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = log (Memd[in+i]) + } + } + + } + + call stk_pop (stack, 1) +end + +# VEX_LOG10 -- Common log function + +procedure vex_log10 (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] <= 0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = log10 (real (Memi[in+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] <= 0.0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = log10 (Memr[in+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] <= 0.0) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = log10 (Memd[in+i]) + } + } + + } + + call stk_pop (stack, 1) +end + +# VEX_MAX -- Maximum of two numbers + +procedure vex_max (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = max (Memi[in[1]+i], Memi[in[2]+i]) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = max (Memr[in[1]+i], Memr[in[2]+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = max (Memd[in[1]+i], Memd[in[2]+i]) + + } + + call stk_pop (stack, 2) +end + +# VEX_MIN -- Minimum of two numbers + +procedure vex_min (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = min (Memi[in[1]+i], Memi[in[2]+i]) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = min (Memr[in[1]+i], Memr[in[2]+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = min (Memd[in[1]+i], Memd[in[2]+i]) + + } + + call stk_pop (stack, 2) +end + +# VEX_MOD -- Remainder function + +procedure vex_mod (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = mod (Memi[in[1]+i], Memi[in[2]+i]) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = mod (Memr[in[1]+i], Memr[in[2]+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = mod (Memd[in[1]+i], Memd[in[2]+i]) + + } + + call stk_pop (stack, 2) +end + +# VEX_MUL -- Multiplication function + +procedure vex_mul (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = Memi[in[1]+i] * Memi[in[2]+i] + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = Memr[in[1]+i] * Memr[in[2]+i] + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = Memd[in[1]+i] * Memd[in[2]+i] + + } + + call stk_pop (stack, 2) +end + +# VEX_NE -- Logical inequality + +procedure vex_ne (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] != Memi[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] != Memr[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] != Memd[in[2]+i]) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_NEG -- Negation function + +procedure vex_neg (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = - Memi[in+i] + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = - Memr[in+i] + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = - Memd[in+i] + + } + + call stk_pop (stack, 1) +end + +# VEX_NINT -- Nearest integer + +procedure vex_nint (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer in, out + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = Memi[in+i] + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = anint (Memr[in+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = anint (Memd[in+i]) + + } + + call stk_pop (stack, 1) +end + +# VEX_NOT -- Logical negation + +procedure vex_not (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] != 0) { + Memi[out+i] = 0 + } else { + Memi[out+i] = 1 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] != 0.0) { + Memi[out+i] = 0 + } else { + Memi[out+i] = 1 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] != 0.0) { + Memi[out+i] = 0 + } else { + Memi[out+i] = 1 + } + } + } + + call stk_pop (stack, 1) +end + +# VEX_OR -- Logical or + +procedure vex_or (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, TY_INT) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in[1]+i] != 0 || Memi[in[2]+i] != 0) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] != 0.0 || Memr[in[2]+i] != 0.0) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] != 0.0 || Memd[in[2]+i] != 0.0) { + Memi[out+i] = 1 + } else { + Memi[out+i] = 0 + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_POW -- Exponentiation function + +procedure vex_pow (stack) + +pointer stack # u: Stack descriptor +#-- +double dtemp +int index, len, type, i +pointer out, in[2] +real rtemp + +double vex_errf() +int stk_pos() +pointer stk_alloc() + +begin + # If the exponent is an integer, use the normal exponentiation + # otherwise, use the logarithmic formulation + + call stk_get (stack, TOP, in[2], len, type) + + if (type == TY_INT) { + index = stk_pos (stack, 2) + call stk_get (stack, index, in[1], len, type) + + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = Memi[in[1]+i] ** Memi[in[2]+i] + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = Memr[in[1]+i] ** Memi[in[2]+i] + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = Memd[in[1]+i] ** Memi[in[2]+i] + } + + } else { + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_REAL: + do i = 0, len-1 { + if (Memr[in[1]+i] <= 0.0) { + Memr[out+i] = vex_errf (stack, i) + } else { + rtemp = Memr[in[2]+i] * log(Memr[in[1]+i]) + if (rtemp > MAX_EXP) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = exp (rtemp) + } + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in[1]+i] <= 0.0) { + Memd[out+i] = vex_errf (stack, i) + } else { + dtemp = Memd[in[2]+i] * log(Memd[in[1]+i]) + if (dtemp > MAX_EXP) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = exp (dtemp) + } + } + } + } + } + + call stk_pop (stack, 2) +end + +# VEX_PUSH -- Push a token onto the stack + +procedure vex_push (stack, getvar, type, token) + +pointer stack # i: Stack structure +extern getvar # i: Function to return a variable +int type # i: Token type +char token[ARB] # i: Token string +#-- +double dval +int len, ic, nc, ival +pointer sp, errmsg, var +real rval + +string badtype "Unrecognized token type (%d)" + +int ctoi(), ctor(), ctod() +pointer stk_alloc() +errchk getvar + +begin + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + len = STK_LENVAL(stack) + + switch (type) { + case Y_VAR: + call getvar (stack, token) + + case Y_INT: + var = stk_alloc (stack, len, TY_INT) + + ic = 1 + len = max (len, 1) + nc = ctoi (token, ic, ival) + call amovki (ival, Memi[var], len) + + case Y_REAL: + var = stk_alloc (stack, len, TY_REAL) + + ic = 1 + len = max (len, 1) + nc = ctor (token, ic, rval) + call amovkr (rval, Memr[var], len) + + case Y_DOUBLE: + var = stk_alloc (stack, len, TY_DOUBLE) + + ic = 1 + len = max (len, 1) + nc = ctod (token, ic, dval) + call amovkd (dval, Memd[var], len) + + default: + call sprintf (Memc[errmsg], SZ_LINE, badtype) + call pargi (type) + call error (1, Memc[errmsg]) + } + + call sfree (sp) +end + +# VEX_REAL -- Convert to real + +procedure vex_real (stack) + +pointer stack # u: Stack descriptor +#-- +pointer out + +begin + call stk_coerce (stack, TOP, TY_REAL, out) + +end + +# VEX_SIG -- Sign transfer function + +procedure vex_sig (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = sign (Memi[in[1]+i], Memi[in[2]+i]) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = sign (Memr[in[1]+i], Memr[in[2]+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = sign (Memd[in[1]+i], Memd[in[2]+i]) + + } + + call stk_pop (stack, 2) +end + +# VEX_SIN -- Sine function + +procedure vex_sin (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memr[out+i] = sin (real (Memi[in+i])) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = sin (Memr[in+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = sin (Memd[in+i]) + + } + + call stk_pop (stack, 1) +end + +# VEX_SINH -- Hyperbolic sine function + +procedure vex_sinh (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] > MAX_EXP) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = sinh (real (Memi[in+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] > MAX_EXP) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = sinh (Memr[in+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] > MAX_EXP) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = sinh (Memd[in+i]) + } + } + } + + call stk_pop (stack, 1) +end + +# VEX_SQR -- Second power + +procedure vex_sqr (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = Memi[in+i] * Memi[in+i] + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = Memr[in+i] * Memr[in+i] + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = Memd[in+i] * Memd[in+i] + + } + + call stk_pop (stack, 1) +end + +# VEX_SQRT -- Square root function + +procedure vex_sqrt (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +double vex_errf() +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 { + if (Memi[in+i] < 0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = sqrt (real (Memi[in+i])) + } + } + + case TY_REAL: + do i = 0, len-1 { + if (Memr[in+i] < 0.0) { + Memr[out+i] = vex_errf (stack, i) + } else { + Memr[out+i] = sqrt (Memr[in+i]) + } + } + + case TY_DOUBLE: + do i = 0, len-1 { + if (Memd[in+i] < 0.0) { + Memd[out+i] = vex_errf (stack, i) + } else { + Memd[out+i] = sqrt (Memd[in+i]) + } + } + + } + + call stk_pop (stack, 1) +end + +# VEX_SUB -- Subtraction function + +procedure vex_sub (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in[2] + +pointer stk_alloc() + +begin + call stk_fetch (stack, 2, in, len, type) + out = stk_alloc (stack, len, type) + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memi[out+i] = Memi[in[1]+i] - Memi[in[2]+i] + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = Memr[in[1]+i] - Memr[in[2]+i] + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = Memd[in[1]+i] - Memd[in[2]+i] + + } + + call stk_pop (stack, 2) +end + +# VEX_TAN -- Tangent function + +procedure vex_tan (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memr[out+i] = tan (real (Memi[in+i])) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = tan (Memr[in+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = tan (Memd[in+i]) + + } + + call stk_pop (stack, 1) +end + +# VEX_TANH -- Hyperbolic tangent function + +procedure vex_tanh (stack) + +pointer stack # u: Stack descriptor +#-- +int len, type, i +pointer out, in + +pointer stk_alloc() + +begin + call stk_fetch (stack, 1, in, len, type) + if (type == TY_INT) { + out = stk_alloc (stack, len, TY_REAL) + } else { + out = stk_alloc (stack, len, type) + } + len = max (len, 1) + + switch (type) { + case TY_INT, TY_LONG: + do i = 0, len-1 + Memr[out+i] = tanh (real (Memi[in+i])) + + case TY_REAL: + do i = 0, len-1 + Memr[out+i] = tanh (Memr[in+i]) + + case TY_DOUBLE: + do i = 0, len-1 + Memd[out+i] = tanh (Memd[in+i]) + + } + + call stk_pop (stack, 1) +end + + + + diff --git a/pkg/utilities/nttools/stxtools/vexstack.x b/pkg/utilities/nttools/stxtools/vexstack.x new file mode 100644 index 00000000..8f51b2bb --- /dev/null +++ b/pkg/utilities/nttools/stxtools/vexstack.x @@ -0,0 +1,585 @@ +include "vex.h" + +# VEX_STACK -- Procedures which manipulate the vex stack +# +# The expression evaluator, vex_eval, uses a stack to hold intermediate +# results, constants, and variable names in the expression. There are +# actually two stacks, a type stack wich contains the data types of the +# elements on the stack, and a value stack, which contains pointers to +# the stack elements. Constants and variable names are stored in two +# buffers which are part of the stack structure and pointers to their +# locations are placed on the stack. Intermediate results are stored in +# malloc'ed arrays and their pointers are also placed on the stack. The +# stack structure contains three indices, bottom, an index one greater +# than the last constant or variable name, top, an index that is one +# greater than the current top of stack, and high, an index that is one +# greater than the last valid pointer on the stack. Valid pointers exist +# beyond the top of stack because the arrays which store intermediate +# results are not mfree'd when the stack is popped, instead, they are +# kept in case they may be needed for a future intermediate result. The +# only user callable procedure in this file is stk_alloc, which should +# be called by getvar, the user's function which fills an array when +# passed the name of a variable. +# +# B.Simon 24-Apr-91 Original +# B.Simon 15-Oct-98 Store strings in pseudocode, not on stack + +# STK_ALLOC -- Allocate an array of the specified length and type + +pointer procedure stk_alloc (stack, len, type) + +pointer stack # i: Stack structure +int len # i: Length of array to allocate +int type # i: Data type of array (spp type) +#-- +int index, stype, top +pointer var, svar + +string badstack "stk_alloc: illegal type on stack" +string badsize "Requested array size does not match previous requests" + +errchk stk_find + +begin + # Check to see if array length is being defined for the first time + + if (STK_LENVAL(stack) == 0 && len != 0) { + + # Store length in stack structure + + STK_LENVAL(stack) = len + + # Free all stack arrays not currently being used + + index = STK_TOP(stack) + while (index < STK_HIGH(stack)) { + svar = STK_VALUE(stack,index) + stype = STK_TYPE(stack,index) + call mfree (svar, stype) + index = index + 1 + } + STK_HIGH(stack) = STK_TOP(stack) + + # Reallocate the null buffer + + if (STK_NULLARY(stack) != NULL) { + call stk_freenull (stack) + call stk_initnull (stack, true) + } + + # Convert length one arrays to their full length + + index = 0 + while (index < STK_TOP(stack)) { + svar = STK_VALUE(stack,index) + stype = STK_TYPE(stack,index) + + call malloc (var, len, stype) + STK_VALUE(stack,index) = var + switch (stype) { + case TY_INT,TY_LONG: + call amovki (Memi[svar], Memi[var], len) + call mfree (svar, TY_INT) + case TY_REAL: + call amovkr (Memr[svar], Memr[var], len) + call mfree (svar, TY_REAL) + case TY_DOUBLE: + call amovkd (Memd[svar], Memd[var], len) + call mfree (svar, TY_DOUBLE) + default: + call error (1, badstack) + } + index = index + 1 + } + } + + # Check requested size + + if (len != 0 && len != STK_LENVAL(stack)) + call error (1, badsize) + + # Look for an existing array of the same type + + call stk_find (stack, type, index) + + # Increment top of stack pointer + + top = STK_TOP(stack) + STK_TOP(stack) = top + 1 + + # Swap array with one currently at top of stack + + if (top != index) { + stype = STK_TYPE(stack,top) + STK_TYPE(stack,top) = STK_TYPE(stack,index) + STK_TYPE(stack,index) = stype + + svar = STK_VALUE(stack,top) + STK_VALUE(stack,top) = STK_VALUE(stack,index) + STK_VALUE(stack,index) = svar + } + + var = STK_VALUE(stack,top) + return (var) +end + +# STK_CLEAR -- Clear all stack elements above the bottom + +procedure stk_clear (stack) + +pointer stack # u: Stack pointer +#-- +int index + +begin + # Free all value arrays above the bottom of stack + + index = 0 + while (index < STK_HIGH(stack)) { + call mfree (STK_VALUE(stack,index), STK_TYPE(stack,index)) + index = index + 1 + } + + # Free null array + + call stk_freenull (stack) + + # Reset scalars + + STK_TOP(stack) = 0 + STK_HIGH(stack) = 0 + STK_LENVAL(stack) = 0 +end + +# STK_COERCE -- Coerce an array in the stack to the specified type + +procedure stk_coerce (stack, pos, type, var) + +pointer stack # i: Stack descriptor +int pos # i: Position of array in stack +int type # i: New type for array +pointer var # o: New pointer to array +#-- +int index, last, stype, len, i +pointer svar + +string underflow "stk_coerce: underflow in expression evaluator" + +errchk stk_find + +begin + # Convert relative to absolute position + + if (pos == TOP) { + index = STK_TOP(stack) - 1 + if (index < 0) + call error (1, underflow) + } else { + index = pos + } + + # If type of array matches requested type, return pointer to array + # Otherwise, get new array and copy old array to it + + if (type == STK_TYPE(stack,index)) { + var = STK_VALUE(stack,index) + + } else { + # Find array of correct type + + last = index + call stk_find (stack, type, index) + + # Copy array, converting to new type + + len = max (1, STK_LENVAL(stack)) + var = STK_VALUE(stack,index) + + stype = STK_TYPE(stack,last) + svar = STK_VALUE(stack,last) + + switch (type) { + case TY_INT,TY_LONG: + switch (stype) { + case TY_INT,TY_LONG: + ; # can't happen + case TY_REAL: + do i = 0, len-1 { + if (IS_INDEFR(Memr[svar+i])) { + Memi[var+i] = INDEFI + } else { + Memi[var+i] = Memr[svar+i] + } + } + case TY_DOUBLE: + do i = 0, len-1 { + if (IS_INDEFD(Memd[svar+i])) { + Memi[var+i] = INDEFI + } else { + Memi[var+i] = Memd[svar+i] + } + } + } + case TY_REAL: + switch (stype) { + case TY_INT,TY_LONG: + do i = 0, len-1 { + if (IS_INDEFI(Memi[svar+i])) { + Memr[var+i] = INDEFR + } else { + Memr[var+i] = Memi[svar+i] + } + } + case TY_REAL: + ; # can't happen + case TY_DOUBLE: + do i = 0, len-1 { + if (IS_INDEFD(Memd[svar+i])) { + Memr[var+i] = INDEFR + } else { + Memr[var+i] = Memd[svar+i] + } + } + } + case TY_DOUBLE: + switch (stype) { + case TY_INT,TY_LONG: + do i = 0, len-1 { + if (IS_INDEFI(Memi[svar+i])) { + Memd[var+i] = INDEFD + } else { + Memd[var+i] = Memi[svar+i] + } + } + case TY_REAL: + do i = 0, len-1 { + if (IS_INDEFR(Memr[svar+i])) { + Memd[var+i] = INDEFD + } else { + Memd[var+i] = Memr[svar+i] + } + } + case TY_DOUBLE: + ; # can't happen + } + } + + # Swap position of new and old arrays on stack + + STK_TYPE(stack,last) = STK_TYPE(stack,index) + STK_TYPE(stack,index) = stype + + STK_VALUE(stack,last) = STK_VALUE(stack,index) + STK_VALUE(stack,index) = svar + } + +end + +# STK_FETCH -- Fetch the specified number of arrays from the stack + +procedure stk_fetch (stack, nvar, var, len, type) + +pointer stack # i: Stack descriptor +int nvar # i: Number of pointers requested +pointer var[ARB] # o: Array pointers +int len # o: Length of arrays +int type # o: Type of arrays +#-- +int one, two, index, ivar + +string underflow "stk_fetch: underflow in expression evaluator" + +errchk stk_coerce + +begin + # If length is not yet defined, STK_LENVAL equals zero + + len = STK_LENVAL(stack) + + # Find the highest type in the pointers to be returned + + one = STK_TOP(stack) - 1 + two = STK_TOP(stack) - 2 + + type = STK_TYPE(stack,one) + if (nvar > 1) { + switch (STK_TYPE(stack,two)) { + case TY_INT, TY_LONG: + ; + case TY_REAL: + if (type == TY_INT) + type = TY_REAL + case TY_DOUBLE: + type = TY_DOUBLE + } + } + + # Retrieve pointers to arrays from stack. var[nvar] is top of stack + # Convert arrays to output type when the type differs + + index = STK_TOP(stack) - nvar + do ivar = 1, nvar { + if (index < 0) + call error (1, underflow) + + if (type == STK_TYPE(stack,index) || index < two) { + var[ivar] = STK_VALUE(stack,index) + } else { + call stk_coerce (stack, index, type, var[ivar]) + } + index = index + 1 + } + +end + +# STK_FIND -- Find a free array of the proper type on the stack + +procedure stk_find (stack, type, index) + +pointer stack # i: Stack descriptor +int type # i: Required type +int index # o: Position on the stack +#-- +int len +pointer var + +string overflow "Expression too complex to be evaluated" + +begin + # Try to find an array of the proper type already on the stack + + index = STK_TOP(stack) + while (index < STK_HIGH(stack)) { + if (type == STK_TYPE(stack,index)) + break + + index = index + 1 + } + + # If not found, allocate a new array + + if (index == MAX_STACK) { + call error (1, overflow) + + } else if (index == STK_HIGH(stack)) { + len = max (1, STK_LENVAL(stack)) + call malloc (var, len, type) + + STK_TYPE(stack,index) = type + STK_VALUE(stack,index) = var + STK_HIGH(stack) = STK_HIGH(stack) + 1 + } + +end + +# STK_FREE -- Free memory used by the stack + +procedure stk_free (stack) + +pointer stack # u: Stack pointer +#-- + +begin + # Free all values above the stack bottom + + call stk_clear (stack) + + # Free substructures in stack + + if (STK_NULLARY(stack) != NULL) + call mfree (STK_NULLARY(stack), TY_BOOL) + + call mfree (STK_VALARY(stack), TY_INT) + call mfree (STK_TYPARY(stack), TY_INT) + + # Free the stack structure + call mfree (stack, TY_INT) +end + +# STK_FREENULL -- Free the null array in the stack + +procedure stk_freenull (stack) + +pointer stack # u: Stack structure +#-- + +begin + if (STK_NULLARY(stack) != NULL) + call mfree (STK_NULLARY(stack), TY_BOOL) + + STK_NULLARY(stack) = NULL +end + +# STK_GET -- Get a single array from the stack + +procedure stk_get (stack, pos, var, len, type) + +pointer stack # i: Stack descriptor +int pos # i: Position on the stack +pointer var # o: Pointer to array +int len # o: Length of array +int type # o: Type of the array +#-- +int index + +string underflow "stk_get: underflow in expression evaluator" + +begin + # Convert relative to absolute position + + if (pos == TOP) { + index = STK_TOP(stack) - 1 + if (index < 0) + call error (1, underflow) + } else { + index = pos + } + + var = STK_VALUE(stack,index) + len = STK_LENVAL(stack) + type = STK_TYPE(stack,index) +end + +# STK_GETNULL -- Get the null array from the stack + +procedure stk_getnull (stack, nullvec) + +pointer stack # i: Stack structure +pointer nullvec # o: Null array +#-- + +begin + nullvec = STK_NULLARY(stack) +end + +# STK_INIT -- Initialize the stack + +procedure stk_init (stack) + +pointer stack # o: Stack pointer +#-- + +begin + # Allocate stack and initialize members to zero + + call calloc (stack, SZ_STKSTRUCT, TY_INT) + + # Allocate substructures in stack + + call malloc (STK_VALARY(stack), MAX_STACK, TY_INT) + call malloc (STK_TYPARY(stack), MAX_STACK, TY_INT) + +end + +# STK_INITNULL -- Initialize the null array on the stack + +procedure stk_initnull (stack, value) + +pointer stack # u: Stack structure +bool value # i: Value used in initialization +#-- +int len, i +pointer nullvec + +begin + # Only initialize if array doesn't exist + + if (STK_NULLARY(stack) == NULL) { + len = STK_LENVAL(stack) + + # Allocate array + call malloc (nullvec, len, TY_BOOL) + STK_NULLARY(stack) = nullvec + + # Initialize to value + do i = 0, len-1 + Memb[nullvec+i] = value + } + +end + +# STK_ORNULL -- Update null array by doing a logical or + +procedure stk_ornull (stack, newvec, newlen) + +pointer stack # u: Stack structure +bool newvec[ARB] # i: Array of new values +int newlen # i: Length of new array +#-- +int len, i +pointer nullvec + +string badlength "stk_ornull: length of array does not match null array" + +begin + len = STK_LENVAL(stack) + if (len != newlen) + call error (1, badlength) + + call stk_initnull (stack, false) + nullvec = STK_NULLARY(stack) + + do i = 1, len { + Memb[nullvec] = Memb[nullvec] || newvec[i] + nullvec = nullvec + 1 + } + +end + +# STK_POP -- Remove the specified number of arrays from the stack + +procedure stk_pop (stack, npop) + +pointer stack # u: Stack structure +int npop # i: Number of arrays to pop +#-- +int top, index, type +pointer var + +string underflow "stk_pop: underflow in expression evaluator" + +begin + + top = STK_TOP(stack) - 1 + index = top - npop + + if (index < 0) { + call error (1, underflow) + } else { + STK_TOP(stack) = index + 1 + } + + var = STK_VALUE(stack,index) + STK_VALUE(stack,index) = STK_VALUE(stack,top) + STK_VALUE(stack,top) = var + + type = STK_TYPE(stack,index) + STK_TYPE(stack,index) = STK_TYPE(stack,top) + STK_TYPE(stack,top) = type + +end + +# STK_POS -- Compute absolute position on stack + +int procedure stk_pos (stack, pos) + +pointer stack # i: Stack structure +int pos # i: Position relative to top of stack +#-- + +begin + return (STK_TOP(stack) - pos) +end + +# STK_SETNULL -- Set a single value in the null array to true + +procedure stk_setnull (stack, index) + +pointer stack # u: Stack structure +int index # i: Index into null array +#-- + +begin + STK_NULL(stack,index) = true +end + diff --git a/pkg/utilities/nttools/stxtools/wcslab/mkpkg b/pkg/utilities/nttools/stxtools/wcslab/mkpkg new file mode 100644 index 00000000..f5083925 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/mkpkg @@ -0,0 +1,17 @@ +# WCSLAB + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.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 "psiescape.h" "wcslab.h" "wcs_desc.h" + ; diff --git a/pkg/utilities/nttools/stxtools/wcslab/mkpkg.ori b/pkg/utilities/nttools/stxtools/wcslab/mkpkg.ori new file mode 100644 index 00000000..7108366c --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/mkpkg.ori @@ -0,0 +1,18 @@ +# WCSLAB + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + t_wcslab.x + 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/utilities/nttools/stxtools/wcslab/psiescape.h b/pkg/utilities/nttools/stxtools/wcslab/psiescape.h new file mode 100644 index 00000000..46da4ea2 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/psiescape.h @@ -0,0 +1,80 @@ +.help psiescape.h 1May92 plot +.ih +.NAME +psiescape.h -- Define the special GIO escape instructions. +.ih +DESCRIPTION +The following escape instructions are defined for the PostScript GKI +Interpreter: + + PS_CODE - Send the raw PostScript code to the output. + PS_IMAGE_RED_LUT - Download a new lookup table for the Red component + of an image. + PS_IMAGE_GREEN_LUT - Download a new lookup table for the Green component + of an image. + PS_IMAGE_BLUE_LUT - Download a new lookup table for the Blue component + of an image. + PS_GR_RED_LUT - Download a new lookup table for the Red component + for the graphics. + PS_GR_GREEN_LUT - Download a new lookup table for the Green component + for the graphics. + PS_GR_BLUE_LUT - Download a new lookup table for the Blue component + for the graphics. + PS_ROMAN_FONT - Specify a new font for the normal font. + PS_GREEK_FONT - Specify a new font for the greek font. + PS_ITALIC_FONT - Specify a new font for the italic font. + PS_BOLD_FONT - Specify a new font for the bold font. + PS_VARIABLE_SPACE - Change whether characters are mono-spaced or + variable-spaced. + PS_DASH, PS_DOT, + PS_SPACE - Change the sizes of a dash, a dot, and the space + between them. + PS_FILL_PATTERN - Add/change fill patterns. + +The size of the instruction array should have the following minimums: + - For the PS_CODE instruction, the array should be the length of the string + being passed. + - The size of each image LUT array is PS_IMAGE_LUT_SIZE. + - The size of each graphics LUT array is PS_GR_LUT_SIZE. + - The font arrays should be the length of the string containing the name + of the font to use. + - For the PS_VARIABLE_SPACE, the size is PS_VARIABLE_SPACE_SIZE. + - For PS_FILL_PATTERN, the size is PS_FILL_SIZE. + +.ih +SEE ALSO +t_psikern +.endhelp +#--------------------------------------------------------------------------- + +# Define the escape instructions. +define PS_CODE 1001 +define PS_IMAGE_RED_LUT 1002 +define PS_IMAGE_GREEN_LUT 1003 +define PS_IMAGE_BLUE_LUT 1004 +define PS_GR_RED_LUT 1005 +define PS_GR_GREEN_LUT 1006 +define PS_GR_BLUE_LUT 1007 +define PS_ROMAN_FONT 1008 +define PS_GREEK_FONT 1009 +define PS_ITALIC_FONT 1010 +define PS_BOLD_FONT 1011 +define PS_VARIABLE_SPACE 1012 +define PS_DOT 1013 +define PS_DASH 1014 +define PS_SPACE 1015 +define PS_FILL_PATTERN 1016 +define PS_IMAGE_LUT 1017 +define PS_GRAPHICS_LUT 1018 + +# Define the sizes of the instruction arrays. +define PS_MAX_LUT_VALUE 255 +define PS_IMAGE_LUT_SIZE 256 +define PS_GR_LUT_SIZE 16 +define PS_VARIABLE_SPACE_SIZE 1 +define PS_FILL_SIZE 9 + +# Define how to pack/unpack a LUT defined as reals from 0-1 into +# a short array from 0-PS_MAX_LUT_VALUE. +define PS_PACKLUT (int($1*PS_MAX_LUT_VALUE)) +define PS_UNPACKLUT ($1/real(PS_MAX_LUT_VALUE)) diff --git a/pkg/utilities/nttools/stxtools/wcslab/t_wcslab.x b/pkg/utilities/nttools/stxtools/wcslab/t_wcslab.x new file mode 100644 index 00000000..acafdf2f --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/t_wcslab.x @@ -0,0 +1,136 @@ +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 ("append")) + 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 (mode == 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") + call wl_imd_viewport (frame, im, c1, c2, l1, l2, vl, vr, vb, vt) + gp = gopen (Memc[device], NEW_FILE, STDGRAPH) + + # Otherwise set up a standard viewport. + } else { + vl = clgetr ("vl") + vr = clgetr ("vr") + vb = clgetr ("vb") + vt = clgetr ("vt") + gp = gopen (Memc[device], NEW_FILE, 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/utilities/nttools/stxtools/wcslab/wcs_desc.h b/pkg/utilities/nttools/stxtools/wcslab/wcs_desc.h new file mode 100644 index 00000000..4f6b2a30 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/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/utilities/nttools/stxtools/wcslab/wcslab.h b/pkg/utilities/nttools/stxtools/wcslab/wcslab.h new file mode 100644 index 00000000..cf088323 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/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|" +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/utilities/nttools/stxtools/wcslab/wcslab.x b/pkg/utilities/nttools/stxtools/wcslab/wcslab.x new file mode 100644 index 00000000..2e6974c6 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/wcslab.x @@ -0,0 +1,935 @@ +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 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_BOOL) + 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_BOOL) + 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 +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, 1, 2, "linear", empty) + + } else if (strncmp (input, "ra--", 4) == 0) { + i = strldx ("-", input) + 1 + call mw_swtype (mw, 1, 2, input[i], empty) + call mw_swattrs (mw, axno, "axtype", "ra") + + } else if (strncmp (input, "dec-", 4) == 0) { + i = strldx ("-", input) + 1 + call mw_swtype (mw, 1, 2, input[i], empty) + call mw_swattrs (mw, axno, "axtype", "dec") + + } 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, 1, 2, "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/utilities/nttools/stxtools/wcslab/wlgrid.x b/pkg/utilities/nttools/stxtools/wcslab/wlgrid.x new file mode 100644 index 00000000..4f457af4 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/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 "psiescape.h" +include "wcslab.h" +include "wcs_desc.h" + + +# Define the offset array. +define OFFSET Memr[$1+$2-1] + +# Define the postscript kernel +define PSIKERN "psikern" + +# 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, streq() +int i, axis1_side, axis2_side +short flag +pointer kernel, 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. + call salloc (kernel, SZ_LINE, TY_CHAR ) + + # 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 + } + + # Check to see if this is a psikern printer. If so, set text + # so that it is mono-spaced. The superscripting algorithm + # doesn't work too well in a proportional-spaced system. + call ggets (WL_GP(wd), "tn", Memc[kernel], SZ_LINE ) + if (streq (Memc[kernel], PSIKERN)) { + flag = NO + call gescape (WL_GP(wd), PS_VARIABLE_SPACE, flag, + PS_VARIABLE_SPACE_SIZE) + } + + # 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 + } + + # Reset to variable spacing. + if (streq (Memc[kernel], PSIKERN)) { + flag = YES + call gescape (WL_GP(wd), PS_VARIABLE_SPACE, flag, + PS_VARIABLE_SPACE_SIZE) + } + + # 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/utilities/nttools/stxtools/wcslab/wllabel.x.ori b/pkg/utilities/nttools/stxtools/wcslab/wllabel.x.ori new file mode 100644 index 00000000..33e86878 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/wcslab/wllabel.x.ori @@ -0,0 +1,1077 @@ +include +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/utilities/nttools/stxtools/wcslab/wlsetup.x b/pkg/utilities/nttools/stxtools/wcslab/wlsetup.x new file mode 100644 index 00000000..c37e24ca --- /dev/null +++ b/pkg/utilities/nttools/stxtools/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/utilities/nttools/stxtools/wcslab/wlutil.x b/pkg/utilities/nttools/stxtools/wcslab/wlutil.x new file mode 100644 index 00000000..c79b8f5e --- /dev/null +++ b/pkg/utilities/nttools/stxtools/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/utilities/nttools/stxtools/wcslab/wlwcslab.x b/pkg/utilities/nttools/stxtools/wcslab/wlwcslab.x new file mode 100644 index 00000000..156c9a8a --- /dev/null +++ b/pkg/utilities/nttools/stxtools/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[wcs_save_block-1+$1] +define OLD_NDC_WIND Memr[wcs_save_block+3+$1] +define OLD_PLT_VIEW Memr[wcs_save_block+7+$1] +define OLD_PLT_WIND Memr[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/utilities/nttools/stxtools/word.x b/pkg/utilities/nttools/stxtools/word.x new file mode 100644 index 00000000..c6b33191 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/word.x @@ -0,0 +1,229 @@ +# Definition of delimeters used in parsing words + +define IS_DELIM (($1) <= ' ' || ($1) == ',') +define NOT_DELIM (($1) > ' ' && ($1) != ',') + +.help +.nf_________________________________________________________________________ + +The procedures in this file perform simple processing on lists of +words. These procedures count the number of words in a list, fetch +the next word in a list, find the n-th word in a list, check for an +exact match between a word and a list of words. A word is any group +of contiguous characters which are neither whitespace or commas. The +definition of whitespace is anomalous, it includes any character whose +integer value is less than or equal to a blank. Note that words cannot +be delimeted by quotes and that escape processing is not done. + +.endhelp____________________________________________________________________ + +#______________________________HISTORY______________________________________ +# +# B.Simon 20-Apr-1990 Modified versions of CDBS routines adb_*tok.x +# +#___________________________________________________________________________ + +# WORD_COUNT -- Return the number of words in a list of words + +int procedure word_count (list) + +char list[ARB] # i: List of words +#-- +char ch +int count, ic + +begin + + # The absolute value of count is the number of the current + # word of the list, count is negative if we are currently + # between words. + + count = 0 + + # Loop over all characters in the list + + for (ic = 1 ; list[ic] != EOS; ic = ic + 1) { + ch = list[ic] + + if (count > 0) { + if (IS_DELIM(ch)) + count = - count + + } else if (NOT_DELIM(ch)) { + count = - count + 1 + } + } + + return (abs(count)) +end + +# WORD_FETCH -- Retrieve next word from string + +int procedure word_fetch (str, ic, word, maxch) + +char str[ARB] # i: String containing words +int ic # io: Index of starting character +char word[ARB] # o: Word string +int maxch # i: Declared length of output string +#-- +char ch +int jc + +begin + # Skip leading whitespace or commas. Don't go past string terminator. + + for (ch = str[ic]; IS_DELIM(ch); ch = str[ic]) { + if (ch == EOS) + break + ic = ic + 1 + } + + # Copy characters to word. End when maxch is reached, or + # when commas, whitespace, or EOS is found + + for (jc = 1; jc <= maxch; jc = jc + 1) { + if (IS_DELIM(ch)) + break + + word[jc] = ch + ic = ic + 1 + ch = str[ic] + } + word[jc] = EOS + + # If loop is terminated because of maxch, eat remaining characters + # in field + + while (NOT_DELIM(ch)) { + ic = ic + 1 + ch = str[ic] + } + + # Return number of characters in word + + return (jc - 1) + +end + +# WORD_FIND -- Find the i-th word in a list of words + +int procedure word_find (index, list, word, maxch) + +int index # i: Index to word within list +char list[ARB] # i: List of words +char word[ARB] # o: Word returned by this procedure +int maxch # i: Declared length of output string +#-- +char ch +int count, ic, jc + +begin + # The absolute value of count is the number of the current + # word of the list, count is negative if we are currently + # between words + + count = 0 + + # Loop until i-th word is reached in list + + for (ic = 1 ; count < index && list[ic] != EOS; ic = ic + 1) { + ch = list[ic] + + if (count > 0) { + if (IS_DELIM(ch)) + count = - count + + } else if (NOT_DELIM(ch)) { + count = - count + 1 + } + } + + # If index is out of bounds, return zero + + if (index < 0 || index > count) + return (0) + + jc = 1 + for (ic = ic - 1; NOT_DELIM(list[ic]); ic = ic + 1) { + if (jc > maxch) + break + + word[jc] = list[ic] + jc = jc + 1 + } + word[jc] = EOS + + # Return number of characters in word + + return (jc - 1) +end + +# WORD_MATCH -- Return number of the word in the list which matches the word + +int procedure word_match (word, list) + +char word[ARB] # i: Word to be matched +char list[ARB] # i: List of words +#-- +char ch +int match, inword, ic, jc + +begin + # The absolute value of inword is the number of the current + # word of the list, inword is negative if we are currently + # between words in the list + + jc = 1 + match = 0 + inword = 0 + + # Loop over all characters in the list + + for (ic = 1 ; list[ic] != EOS; ic = ic + 1) { + ch = list[ic] + + # First case: current character is within a word + + if (inword > 0) { + + # Check for conversion to second case + + if (IS_DELIM(ch)) { + inword = - inword + + # Simultaneous end of word in list and word + # means a match has been found + + if (match != 0 && word[jc] == EOS) + break + else + match = 0 + + } else if (match != 0) { + + # Check for match between list and word + + if (ch == word[jc]) + jc = jc + 1 + else + match = 0 + } + + # Second case: current character is between words + # Check for conversion to first case + + } else if (NOT_DELIM(ch)) { + jc = 1 + ic = ic - 1 + inword = - inword + 1 + match = inword + } + } + + # If list ended before word, there was no match + + if (word[jc] != EOS) + match = 0 + + return (match) +end diff --git a/pkg/utilities/nttools/stxtools/xtwcs.x b/pkg/utilities/nttools/stxtools/xtwcs.x new file mode 100644 index 00000000..aa8b2798 --- /dev/null +++ b/pkg/utilities/nttools/stxtools/xtwcs.x @@ -0,0 +1,1286 @@ +include +include + +# This file contains the following high-level routines for converting +# between world coordinates and pixel coordinates: +# +# xt_wcs_init initialize struct for world coordinate system +# xt_wcs_init_c initialize from input cdelt, crota, etc +# xt_wcs_init_cd initialize from input CD matrix, etc +# xt_wcs_free deallocate wcs struct +# xt_wc_pix convert from world coordinates to pixel coordinates +# xt_pix_wc convert from pixel coordinates to world coordinates +# +# Phil Hodge, 27-Sept-1988 Created, based on code by Nelson & Zolt. +# Phil Hodge, 6-April-1990 CD matrix mult. was transposed in xt_pix_wc. +# Phil Hodge, 26-July-1991 In xt_e_ctype, change GBS to GLS (global sine). + +define LEN_WCS 136 # size of wcs struct for naxis <= 7 + +define W_VALID Memi[$1] # coordinates valid, YES or NO? +define W_NAXIS Memi[$1+1] # number of axes +define W_RA_AX Memi[$1+2] # which axis is RA? zero if none +define W_DEC_AX Memi[$1+3] # which axis is Dec? zero if none +define W_PROJECTION Memi[$1+4] # projection type + +# 6 is currently not used + +# 7 - 55: full CD matrix (7x7); units = e.g. degrees +# 56 - 104: LU decomposition of CD matrix +# 105 - 111: index returned by ludcmp for use by lubksb +# 112 - 118: reference pixel location +# 119 - 122: cosine & sine of declination at the reference pixel +# 123 - 136: coordinates at crpix; units = e.g. degrees + +define W_CD Memr[P2R($1+6 +($2-1)+($3-1)*7)] +define W_CDLU Memr[P2R($1+55 +($2-1)+($3-1)*7)] +define W_CDINDX Memr[P2R($1+104)] # this is an array of 7 +define W_CRPIX Memr[P2R($1+110+$2)] +define W_COSDEC Memd[P2D($1+118)] +define W_SINDEC Memd[P2D($1+120)] +define W_CRVAL Memd[P2D($1+120)+$2] + +# Projection types. + +define W_LINEAR 0 +define W_GNOMONIC 1 # TAN +define W_SINE 2 # SIN +define W_ARC 3 # ARC +define W_NORTH_POLAR 4 # NCP, north celestial pole (Westerbork) +define W_STEREOGRAPHIC 5 # STG (conformal) +define W_AITOFF 6 # AIT (equal-area) +define W_GLOBAL_SINE 7 # GLS (equal-area) +define W_MERCATOR 8 # MER (conformal) + + +# xt_wcs_init -- initialize wcs struct +# This routine allocates space for a structure describing the world +# coordinate system for an image, fills in the values or defaults, and +# returns a pointer to that structure. + +procedure xt_wcs_init (im, wcs) + +pointer im # i: pointer to image descriptor +pointer wcs # o: pointer to world coord system struct +#-- +real dummy # returned by ludcmp and ignored +int ira, idec # index of RA, Dec axes +int j, k # loop indexes +errchk xt_load_ctstruct + +begin + call calloc (wcs, LEN_WCS, TY_STRUCT) + + W_VALID(wcs) = YES # initial value + W_NAXIS(wcs) = IM_NDIM(im) + + call xt_load_wcsstruct (im, wcs) # get CRVAL, etc from image + + if (W_NAXIS(wcs) >= 2) { + + ira = W_RA_AX(wcs) + idec = W_DEC_AX(wcs) + + if (idec > 0) { + W_COSDEC(wcs) = cos (DEGTORAD(W_CRVAL(wcs,idec))) + W_SINDEC(wcs) = sin (DEGTORAD(W_CRVAL(wcs,idec))) + } else { + W_COSDEC(wcs) = 1.d0 + W_SINDEC(wcs) = 0.d0 + } + + # Copy the CD matrix to W_CDLU, and do the LU decomposition + # on W_CDLU in-place. + do k = 1, IM_MAXDIM + do j = 1, IM_MAXDIM + W_CDLU(wcs,j,k) = W_CD(wcs,j,k) + + iferr { + call ludcmp (W_CDLU(wcs,1,1), W_NAXIS(wcs), IM_MAXDIM, + W_CDINDX(wcs), dummy) + } then { + call mfree (wcs, TY_STRUCT) + call error (0, "xt_wcs_init: cd matrix is singular") + } + } +end + + +# xt_wcs_free -- deallocate wcs struct +# This routine deallocates space for a wcs structure. + +procedure xt_wcs_free (wcs) + +pointer wcs # io: pointer to world coord system struct +#-- + +begin + if (wcs != NULL) + call mfree (wcs, TY_STRUCT) +end + + +# xt_wcs_init_c -- initialize wcs struct +# xt_wcs_init_c and xt_wcs_init_cd allocate space for a structure +# describing the world coordinate system for an image, fill in the values +# or defaults, and return a pointer to that structure. They differ from +# xt_wcs_init in that these take the coordinate parameters as arguments +# rather than getting them from the image. +# xt_wcs_init_c takes cdelt & crota, and xt_wcs_init_cd takes the CD matrix. + +procedure xt_wcs_init_c (crval, crpix, cdelt, crota, ctype, naxis, wcs) + +double crval[naxis] # i: coordinate values at reference pixel +real crpix[naxis] # i: reference pixel +real cdelt[naxis] # i: pixel spacing +real crota # i: rotation angle (if 2-D) +char ctype[SZ_CTYPE,naxis] # i: e.g. "RA---TAN" +int naxis # i: size of arrays +pointer wcs # o: pointer to world coord system struct +#-- +real dummy # returned by ludcmp and ignored +int ira, idec # index of RA, Dec axes +int j, k # loop indexes +errchk ludcmp + +begin + do k = 1, naxis + if (cdelt[k] == 0.) + call error (0, "xt_wcs_init_c: zero value of CDELT") + + call calloc (wcs, LEN_WCS, TY_STRUCT) + + W_NAXIS(wcs) = naxis + W_VALID(wcs) = YES # initial value + + # Examine ctype to get ira, idec, proj_type. + call xt_e_ctype (ctype, naxis, ira, idec, W_PROJECTION(wcs)) + W_RA_AX(wcs) = ira + W_DEC_AX(wcs) = idec + + do k = 1, naxis { + W_CRVAL(wcs,k) = crval[k] + W_CRPIX(wcs,k) = crpix[k] + } + do k = naxis+1, IM_MAXDIM { + W_CRVAL(wcs,k) = 0.d0 + W_CRPIX(wcs,k) = 1. + } + + if (naxis == 1) { + + W_CD(wcs,1,1) = cdelt[1] + + } else if (naxis >= 2) { + + if (idec > 0) { + W_COSDEC(wcs) = cos (DEGTORAD(W_CRVAL(wcs,idec))) + W_SINDEC(wcs) = sin (DEGTORAD(W_CRVAL(wcs,idec))) + } else { + W_COSDEC(wcs) = 1.d0 + W_SINDEC(wcs) = 0.d0 + } + + # Convert cdelt & crota to the CD matrix. + call xt_to_cd (wcs, cdelt, crota, naxis) + + # Copy the CD matrix, and do the LU decomposition on W_CDLU. + do k = 1, IM_MAXDIM + do j = 1, IM_MAXDIM + W_CDLU(wcs,j,k) = W_CD(wcs,j,k) + + call ludcmp (W_CDLU(wcs,1,1), naxis, IM_MAXDIM, + W_CDINDX(wcs), dummy) + } +end + + +# xt_wcs_init_cd -- initialize wcs struct (CD) + +procedure xt_wcs_init_cd (crval, crpix, cd, ctype, naxis, wcs) + +double crval[naxis] # i: coordinate values at reference pixel +real crpix[naxis] # i: reference pixel +real cd[naxis,naxis] # i: CD matrix +char ctype[SZ_CTYPE,naxis] # i: e.g. "RA---TAN" +int naxis # i: size of arrays +pointer wcs # o: pointer to world coord system struct +#-- +real dummy # returned by ludcmp and ignored +int ira, idec # index of RA, Dec axes +int j, k # loop indexes + +begin + call calloc (wcs, LEN_WCS, TY_STRUCT) + + W_NAXIS(wcs) = naxis + W_VALID(wcs) = YES # initial value + + # Examine ctype to get ira, idec, proj_type. + call xt_e_ctype (ctype, naxis, ira, idec, W_PROJECTION(wcs)) + W_RA_AX(wcs) = ira + W_DEC_AX(wcs) = idec + + do k = 1, naxis { + W_CRVAL(wcs,k) = crval[k] + W_CRPIX(wcs,k) = crpix[k] + } + do k = naxis+1, IM_MAXDIM { + W_CRVAL(wcs,k) = 0.d0 + W_CRPIX(wcs,k) = 1. + } + + if (naxis == 1) { + + W_CD(wcs,1,1) = cd[1,1] + + } else if (naxis >= 2) { + + if (idec > 0) { + W_COSDEC(wcs) = cos (DEGTORAD(W_CRVAL(wcs,idec))) + W_SINDEC(wcs) = sin (DEGTORAD(W_CRVAL(wcs,idec))) + } else { + W_COSDEC(wcs) = 1.d0 + W_SINDEC(wcs) = 0.d0 + } + + # Assign initial values to the CD matrix. + do k = 1, IM_MAXDIM { + do j = 1, IM_MAXDIM { + if (j == k) { + W_CD(wcs,k,k) = 1. + W_CDLU(wcs,k,k) = 1. + } else { + W_CD(wcs,j,k) = 0. + W_CDLU(wcs,j,k) = 0. + } + } + } + + # Copy the CD matrix, and do the LU decomposition on W_CDLU. + do k = 1, naxis { + do j = 1, naxis { + W_CD(wcs,j,k) = cd[j,k] + W_CDLU(wcs,j,k) = cd[j,k] + } + } + + iferr { + call ludcmp (W_CDLU(wcs,1,1), naxis, IM_MAXDIM, + W_CDINDX(wcs), dummy) + } then { + call mfree (wcs, TY_STRUCT) + call error (0, "xt_wcs_init_cd: cd matrix is singular") + } + } +end + +# xt_to_cd -- from cdelt & crota to cd matrix +# This routine computes the CD matrix from CDELT and CROTA. + +procedure xt_to_cd (wcs, cdelt, crota, naxis) + +pointer wcs # i: pointer to world coord system struct +real cdelt[naxis] # i: pixel spacing +real crota # i: rotation angle (if 2-D) +int naxis # i: size of arrays +#-- +real cosrota, sinrota # cosine & sine of crota +real sign_cdelt[2] # one, with sign of cdelt1 or cdelt2 +int ira, idec # index of RA, Dec axes +int j, k # loop indexes + +begin + ira = W_RA_AX(wcs) + idec = W_DEC_AX(wcs) + + if ( ! IS_INDEFD(crota) ) { + cosrota = cos (DEGTORAD(crota)) + sinrota = sin (DEGTORAD(crota)) + } else { + cosrota = 1.d0 + sinrota = 0.d0 + } + + # Initial values for CD matrix. + do k = 1, IM_MAXDIM { + do j = 1, IM_MAXDIM { + if (j == k) + W_CD(wcs,k,k) = 1. + else + W_CD(wcs,j,k) = 0. + } + } + do k = 1, naxis + W_CD(wcs,k,k) = cdelt[k] + + if (ira > 0 && idec > 0) { + + if (cdelt[ira] >= 0.) + sign_cdelt[1] = 1. + else + sign_cdelt[1] = -1. + + if (cdelt[idec] >= 0.) + sign_cdelt[2] = 1. + else + sign_cdelt[2] = -1. + + W_CD(wcs,ira,ira) = cdelt[ira] * cosrota + W_CD(wcs,ira,idec) = abs (cdelt[idec]) * sign_cdelt[1] * sinrota + W_CD(wcs,idec,ira) = -abs (cdelt[ira]) * sign_cdelt[2] * sinrota + W_CD(wcs,idec,idec) = cdelt[idec] * cosrota + } +end + +# xt_e_ctype -- examine ctype +# Examine each element of the ctype array to find which axes (if any) +# are RA & Dec (or glon & glat, etc). Also get the projection type, +# such as gnomonic, if this was specified in ctype. + +procedure xt_e_ctype (ctype, naxis, ra_axis, dec_axis, proj_type) + +char ctype[SZ_CTYPE,naxis] # i: coordinate type, e.g. "RA---TAN" +int naxis # i: dimension +int ra_axis # o: which axis is RA (or glon, etc)? +int dec_axis # o: which axis is Dec (or glat, etc)? +int proj_type # o: type of projection +#-- +char lctype[SZ_CTYPE] # local copy of an element of ctype +char dash # '-' +int k +int index # index of '-' in ctype +int strncmp(), strldx() + +begin + # Assign defaults. + ra_axis = 0 + dec_axis = 0 + if (naxis == 1) + proj_type = W_LINEAR + else + proj_type = W_GNOMONIC + + # Search for "RA", "DEC", etc. + do k = 1, naxis { + # Make a local copy of ctype & make sure it's upper case. + call strcpy (ctype[1,k], lctype, SZ_CTYPE) + call strupr (lctype) + + if (strncmp (lctype, "RA", 2) == 0) + ra_axis = k + else if (strncmp (lctype, "DEC", 3) == 0) + dec_axis = k + + else if (strncmp (lctype, "GLON", 4) == 0) + ra_axis = k + else if (strncmp (lctype, "LL", 2) == 0) + ra_axis = k + else if (strncmp (lctype, "UU", 2) == 0) + ra_axis = k + else if (strncmp (lctype, "ELON", 4) == 0) + ra_axis = k + + else if (strncmp (lctype, "GLAT", 4) == 0) + dec_axis = k + else if (strncmp (lctype, "MM", 2) == 0) + dec_axis = k + else if (strncmp (lctype, "VV", 2) == 0) + dec_axis = k + else if (strncmp (lctype, "ELAT", 4) == 0) + dec_axis = k + } + + if (ra_axis > 0) + k = ra_axis + else if (dec_axis > 0) + k = dec_axis + else + k = 0 + + # If at least one of the axes is like RA or Dec, check to see + # whether a projection type was specified. + if (k > 0) { + dash = '-' + index = strldx (dash, lctype) + if (index > 0) { + index = index + 1 + if (strncmp (lctype[index], "TAN", 3) == 0) + proj_type = W_GNOMONIC + else if (strncmp (lctype[index], "SIN", 3) == 0) + proj_type = W_SINE + else if (strncmp (lctype[index], "ARC", 3) == 0) + proj_type = W_ARC + else if (strncmp (lctype[index], "NCP", 3) == 0) + proj_type = W_NORTH_POLAR + else if (strncmp (lctype[index], "STG", 3) == 0) + proj_type = W_STEREOGRAPHIC + else if (strncmp (lctype[index], "AIT", 3) == 0) + proj_type = W_AITOFF + else if (strncmp (lctype[index], "GLS", 3) == 0) + proj_type = W_GLOBAL_SINE + else if (strncmp (lctype[index], "MER", 3) == 0) + proj_type = W_MERCATOR + } + } +end + + +define SZ_PNAME 8 + +# xt_load_wcsstruct -- load coordinate information +# Get the coordinate information from the image, and load +# that info into the wcs structure. + +procedure xt_load_wcsstruct (im, wcs) + +pointer im # i: pointer to image header struct +pointer wcs # i: pointer to world coord system struct +#-- +char pname[SZ_PNAME] +char ctype[SZ_CTYPE,IM_MAXDIM] +int naxis, iax # dimension of image; loop index for axis +bool cdm_found # true if CD matrix present in image +int imaccf() +double imgetd() +real imgetr() +errchk imgstr, imgetd, imgetr, xt_g_cd_matrix, xt_c_cd_matrix + +begin + naxis = IM_NDIM(im) + + # Get the coordinate info. If anything is missing set W_VALID to NO. + do iax = 1, naxis { + + # CTYPE for each axis. + call sprintf (pname, SZ_PNAME, "ctype%d") + call pargi (iax) + if (imaccf (im, pname) == YES) { + call imgstr (im, pname, ctype[1,iax], SZ_CTYPE) + } else { + call strcpy ("PIXEL", ctype[1,iax], SZ_CTYPE) + W_VALID(wcs) = NO + } + + # CRVAL for each axis + call sprintf (pname, SZ_PNAME, "crval%d") + call pargi (iax) + if (imaccf (im, pname) == YES) { + W_CRVAL(wcs,iax) = imgetd (im, pname) + } else { + W_CRVAL(wcs,iax) = 0.d0 + W_VALID(wcs) = NO + } + + # CRPIX for each axis + call sprintf (pname, SZ_PNAME, "crpix%d") + call pargi (iax) + if (imaccf (im, pname) == YES) { + W_CRPIX(wcs,iax) = imgetr (im, pname) + } else { + W_CRPIX(wcs,iax) = 1. + W_VALID(wcs) = NO + } + } + # Assign reasonable values to the unused elements. + do iax = naxis+1, IM_MAXDIM { + W_CRVAL(wcs,iax) = 0.d0 + W_CRPIX(wcs,iax) = 1. + } + + # Examine ctype array. + call xt_e_ctype (ctype, naxis, + W_RA_AX(wcs), W_DEC_AX(wcs), W_PROJECTION(wcs)) + + # First try to get the CD matrix, and if it isn't there + # get CDELT and CROTA and convert to CD. + + call xt_g_cd_matrix (im, wcs, naxis, cdm_found) + + if ( ! cdm_found ) + call xt_c_cd_matrix (im, wcs, naxis) +end + + +# xt_g_cd_matrix -- get CD matrix +# If the CD matrix is present, get the values and place them into the +# wcs structure. Note that we assume that if *any* of the CD matrix +# parameters are there, they are *all* there. + +define TOLER 1.e-5 + +procedure xt_g_cd_matrix (im, wcs, naxis, cdm_found) + +pointer im # i: image pointer +pointer wcs # i: pointer to wcs structure +int naxis # i: number of axes in image +bool cdm_found # o: true if CD matrix found +#-- +real cd_matrix[IM_MAXDIM,IM_MAXDIM] # the CD matrix +char pname[SZ_PNAME] +int i, j +int imaccf() +real imgetr() +errchk imgetr + +begin + # This is reset below if any element of the CD matrix is found. + cdm_found = false + + # Assign default values. + do j = 1, IM_MAXDIM + do i= 1, IM_MAXDIM + if (i == j) + cd_matrix[i,j] = 1. + else + cd_matrix[i,j] = 0. + + # Get each element of the CD matrix. + do j = 1, naxis { + do i = 1, naxis { + call sprintf (pname, SZ_PNAME, "cd%d_%d") + call pargi (i) + call pargi (j) + if (imaccf (im, pname) == YES) { + cd_matrix[i,j] = imgetr (im, pname) + cdm_found = true + } + } + } + + # Copy to the wcs structure. + do j = 1, IM_MAXDIM + do i = 1, IM_MAXDIM + W_CD(wcs,i,j) = cd_matrix[i,j] +end + + +# xt_c_cd_matrix -- create CD matrix +# If the CD matrix is not present, get the values of CDELT & CROTA, +# convert to the CD matrix, and store the values in the wcs structure. +# Since this is called after trying unsuccessfully to get the CD matrix, +# if cdelt or crota is not present W_VALID will be reset to NO. + +procedure xt_c_cd_matrix (im, wcs, naxis) + +pointer im # i: image pointer +pointer wcs # i: pointer to wcs structure +int naxis # i: number of axes in image +#-- +char pname[SZ_PNAME] # parameter name (e.g. "cdelt1") +real cdelt[IM_MAXDIM] # pixel spacing +real crota # rotation angle in degrees +int k # loop index for axis +int imaccf() +real imgetr() +errchk imgetr + +begin + do k = 1, naxis { + + # CDELT for each axis. + call sprintf (pname, SZ_PNAME, "cdelt%d") + call pargi (k) + if (imaccf (im, pname) == YES) { + cdelt[k] = imgetr (im, pname) + if (cdelt[k] == 0.) + call error (0, "xt_c_cd_matrix: cdelt is zero") + } else { + cdelt[k] = 1. + W_VALID(wcs) = NO + } + } + + # For a 1-D image, assign CD1_1 and return. + if (naxis == 1) { + W_CD(wcs,1,1) = cdelt[1] + return + } + + # CROTA (only one). + call strcpy ("crota1", pname, SZ_PNAME) + if (imaccf (im, pname) == YES) { + crota = imgetr (im, pname) + } else { + crota = 0. + W_VALID(wcs) = NO + } + + # Compute CD matrix from CDELT & CROTA. + call xt_to_cd (wcs, cdelt, crota, naxis) +end + + +# xt_wc_pix -- wcs to pixels +# This routine converts world coordinates to pixel coordinates. +# +# In the 1-D case, CRVAL is subtracted from the coordinate, the +# result is divided by CDELT (same as CD1_1), and CRPIX is added. +# +# For 2-D or higher dimension, if two of the axes are like RA and Dec, +# the input coordinates are converted to standard coordinates Xi +# and Eta. The (Xi, Eta) vector is then multiplied on the left by +# the inverse of the CD matrix, and CRPIX is added. +# The units for axes like Ra & Dec are degrees, not hours or radians. +# For linear axes the conversion is the same as for 1-D. + +procedure xt_wc_pix (wcs, phys, pix, naxis) + +pointer wcs # i: pointer to world coord system struct +double phys[naxis] # i: physical (world) coordinates (e.g. degrees) +real pix[naxis] # o: pixel coordinates +int naxis # i: size of arrays +#-- +double delta_ra # RA of object - RA at reference pixel +double dra_r, dec_r # delta_ra & declination in radians +double xi_r, eta_r # xi & eta in radians +real dphys[IM_MAXDIM] # phys coord - reference coord +int ira, idec # index of RA, Dec axes +int k # loop index +errchk xt_wp_ncp, xt_wp_mer + +begin + do k = 1, naxis + dphys[k] = phys[k] - W_CRVAL(wcs,k) + + if (naxis == 1) { + + pix[1] = dphys[1] / W_CD(wcs,1,1) + W_CRPIX(wcs,1) + + } else { + + ira = W_RA_AX(wcs) + idec = W_DEC_AX(wcs) + + # Convert RA & Dec to Xi & Eta (standard coordinates). + if (ira > 0 && idec > 0) { + + delta_ra = phys[ira] - W_CRVAL(wcs,ira) # double prec + dra_r = DEGTORAD (delta_ra) + dec_r = DEGTORAD (phys[idec]) + + switch (W_PROJECTION(wcs)) { + case W_GNOMONIC: + call xt_wp_tan (wcs, dra_r, dec_r, xi_r, eta_r) + case W_SINE: + call xt_wp_sin (wcs, dra_r, dec_r, xi_r, eta_r) + case W_ARC: + call xt_wp_arc (wcs, dra_r, dec_r, xi_r, eta_r) + case W_NORTH_POLAR: + call xt_wp_ncp (wcs, dra_r, dec_r, xi_r, eta_r) + case W_STEREOGRAPHIC: + call xt_wp_stg (wcs, dra_r, dec_r, xi_r, eta_r) + case W_AITOFF: + call xt_wp_ait (wcs, dra_r, dec_r, xi_r, eta_r) + case W_GLOBAL_SINE: + call xt_wp_gls (wcs, dra_r, dec_r, xi_r, eta_r) + case W_MERCATOR: + call xt_wp_mer (wcs, dra_r, dec_r, xi_r, eta_r) + } + + dphys[ira] = RADTODEG (xi_r) # xi, eta in degrees + dphys[idec] = RADTODEG (eta_r) + } + + # Use LU backsubstitution to get pixel coords from physical coords. + call lubksb (W_CDLU(wcs,1,1), naxis, IM_MAXDIM, + W_CDINDX(wcs), dphys) # dphys is modified in-place + do k = 1, naxis + pix[k] = dphys[k] + W_CRPIX(wcs,k) # copy to output + } +end + + +# xt_pix_wc -- pixels to wcs +# This routine converts pixel coordinates to world coordinates. +# +# In the 1-D case, CRPIX is subtracted from the pixel coordinate, +# the result is multiplied by CDELT (same as CD1_1), and CRVAL is added. +# +# For 2-D or higher dimension, CRPIX is subtracted, and the result is +# multiplied on the left by the CD matrix. If two of the axes are like +# RA and Dec, the pixel coordinates are converted to standard coordinates +# Xi and Eta. The (xi, eta) vector is then converted to differences +# between RA and Dec and CRVAL, and then CRVAL is added to each coordinate. + +procedure xt_pix_wc (wcs, pix, phys, naxis) + +pointer wcs # i: pointer to world coord system struct +real pix[naxis] # i: pixel coordinates +double phys[naxis] # o: physical (world) coordinates +int naxis # i: size of arrays +#-- +double dpix[IM_MAXDIM] # pix coord - crpix +double sum # for matrix multiplication +double dra_r, dec_r # delta_ra & declination in radians +double xi_r, eta_r # xi & eta in radians +int ira, idec # index of RA, Dec axes +int j, k # loop indexes + +begin + do k = 1, naxis + dpix[k] = pix[k] - W_CRPIX(wcs,k) + + if (naxis == 1) { + + phys[1] = dpix[1] * W_CD(wcs,1,1) + W_CRVAL(wcs,1) + + } else { + + do j = 1, naxis { + sum = 0.d0 + do k = 1, naxis + sum = sum + W_CD(wcs,j,k) * dpix[k] + phys[j] = sum + } + + ira = W_RA_AX(wcs) + idec = W_DEC_AX(wcs) + + # Convert Xi & Eta (standard coordinates) to RA & Dec. + if (ira > 0 && idec > 0) { + xi_r = DEGTORAD (phys[ira]) + eta_r = DEGTORAD (phys[idec]) + + switch (W_PROJECTION(wcs)) { + case W_GNOMONIC: + call xt_pw_tan (wcs, xi_r, eta_r, dra_r, dec_r) + case W_SINE: + call xt_pw_sin (wcs, xi_r, eta_r, dra_r, dec_r) + case W_ARC: + call xt_pw_arc (wcs, xi_r, eta_r, dra_r, dec_r) + case W_NORTH_POLAR: + call xt_pw_ncp (wcs, xi_r, eta_r, dra_r, dec_r) + case W_STEREOGRAPHIC: + call xt_pw_stg (wcs, xi_r, eta_r, dra_r, dec_r) + case W_AITOFF: + call xt_pw_ait (wcs, xi_r, eta_r, dra_r, dec_r) + case W_GLOBAL_SINE: + call xt_pw_gls (wcs, xi_r, eta_r, dra_r, dec_r) + case W_MERCATOR: + call xt_pw_mer (wcs, xi_r, eta_r, dra_r, dec_r) + } + + phys[idec] = RADTODEG (dec_r) + phys[ira] = RADTODEG (dra_r) + W_CRVAL(wcs,ira) + if (phys[ira] < 0.d0) + phys[ira] = phys[ira] + 360.d0 + } + do k = 1, naxis + if (k != ira && k != idec) + phys[k] = phys[k] + W_CRVAL(wcs,k) + } +end + + +# xt_wp_tan -- convert from ra & dec using gnomonic projection + +procedure xt_wp_tan (wcs, dra_r, dec_r, xi_r, eta_r) + +pointer wcs # i: pointer to world coord system struct +double dra_r # i: RA of object - RA at reference pixel (radians) +double dec_r # i: declination of object (radians) +double xi_r # o: standard coordinate (radians) +double eta_r # o: standard coordinate (radians) +#-- +double cosdra, sindra # cos & sin of dra_r +double cosdec, sindec # cos & sin of object declination +double cosdist # cos of dist from ref pixel to object + +begin + cosdra = cos (dra_r) + sindra = sin (dra_r) + + cosdec = cos (dec_r) + sindec = sin (dec_r) + + cosdist = sindec * W_SINDEC(wcs) + cosdec * W_COSDEC(wcs) * cosdra + + xi_r = cosdec * sindra / cosdist + eta_r = (sindec * W_COSDEC(wcs) - + cosdec * W_SINDEC(wcs) * cosdra) / cosdist +end + + +# xt_pw_tan -- convert to ra & dec using gnomonic projection +# In rectangular coordinates the vector (1, xi, eta) points toward +# the object; the origin is the observer's location, the x-axis points +# toward the reference pixel, the y-axis is in the direction of increasing +# right ascension, and the z-axis is in the direction of increasing +# declination. The coordinate system is then rotated by the declination so +# the x-axis passes through the equator at the RA of the reference pixel; +# the components of the vector in this coordinate system are used to +# compute (RA - reference_RA) and declination. + +procedure xt_pw_tan (wcs, xi_r, eta_r, dra_r, dec_r) + +pointer wcs # i: pointer to world coord system struct +double xi_r # i: standard coordinate (radians) +double eta_r # i: standard coordinate (radians) +double dra_r # o: RA of object - RA at reference pixel (radians) +double dec_r # o: declination of object (radians) +#-- +double x, y, z # vector (not unit length) pointing toward object + +begin + # Rotate the rectangular coordinate system of the vector (1, xi, eta) + # by the declination so the x-axis will pass through the equator. + x = W_COSDEC(wcs) - eta_r * W_SINDEC(wcs) + y = xi_r + z = W_SINDEC(wcs) + eta_r * W_COSDEC(wcs) + + if (x == 0.d0 && y == 0.d0) + dra_r = 0.d0 + else + dra_r = atan2 (y, x) + dec_r = atan2 (z, sqrt (x*x + y*y)) +end + + +# xt_wp_sin -- convert from ra & dec using sine projection +# +# Reference: AIPS Memo No. 27 by Eric W. Greisen + +procedure xt_wp_sin (wcs, dra_r, dec_r, xi_r, eta_r) + +pointer wcs # i: pointer to world coord system struct +double dra_r # i: RA of object - RA at reference pixel (radians) +double dec_r # i: declination of object (radians) +double xi_r # o: standard coordinate (radians) +double eta_r # o: standard coordinate (radians) +#-- +double cosdra, sindra # cos & sin of delta_ra +double cosdec, sindec # cos & sin of object declination + +begin + cosdra = cos (dra_r) + sindra = sin (dra_r) + + cosdec = cos (dec_r) + sindec = sin (dec_r) + + xi_r = cosdec * sindra + eta_r = sindec * W_COSDEC(wcs) - cosdec * W_SINDEC(wcs) * cosdra +end + + +# xt_pw_sin -- convert to ra & dec using sine projection +# In rectangular coordinates the vector (v1, xi, eta), where +# v1 = sqrt (1 - xi**2 - eta**2), is the location of the object on the +# unit celestial sphere. The x-axis points toward the reference pixel, +# the y-axis is in the direction of increasing right ascension, and the +# z-axis is in the direction of increasing declination. The coordinate +# system is then rotated (around the y-axis) by the declination so the +# x-axis passes through the equator at the RA of the reference pixel; +# the components of the vector in this coordinate system are used to +# compute (RA - reference_RA) and declination. + +procedure xt_pw_sin (wcs, xi_r, eta_r, dra_r, dec_r) + +pointer wcs # i: pointer to world coord system struct +double xi_r # i: standard coordinate (radians) +double eta_r # i: standard coordinate (radians) +double dra_r # o: RA of object - RA at reference pixel (radians) +double dec_r # o: declination of object (radians) +#-- +double v1 # x component of unit vector +double x, y, z # unit vector with x[1] pointing toward equator + +begin + v1 = sqrt (1.d0 - xi_r*xi_r - eta_r*eta_r) + + # Rotate the rectangular coordinate system of the vector (v1, xi, eta) + # by the declination so the x-axis will pass through the equator. + x = v1 * W_COSDEC(wcs) - eta_r * W_SINDEC(wcs) + y = xi_r + z = v1 * W_SINDEC(wcs) + eta_r * W_COSDEC(wcs) + + if (x == 0.d0 && y == 0.d0) + dra_r = 0.d0 + else + dra_r = atan2 (y, x) + dec_r = atan2 (z, sqrt (x*x + y*y)) +end + + +# xt_wp_arc -- convert from ra & dec using arc projection +# +# Reference: AIPS Memo No. 27 by Eric W. Greisen + +procedure xt_wp_arc (wcs, dra_r, dec_r, xi_r, eta_r) + +pointer wcs # i: pointer to world coord system struct +double dra_r # i: RA of object - RA at reference pixel (radians) +double dec_r # i: declination of object (radians) +double xi_r # o: standard coordinate (radians) +double eta_r # o: standard coordinate (radians) +#-- +double cosdra, sindra # cos & sin of delta_ra +double cosdec, sindec # cos & sin of object declination +double theta # distance (radians) from ref pixel to object +double r # theta / sin (theta) + +begin + cosdra = cos (dra_r) + sindra = sin (dra_r) + + cosdec = cos (dec_r) + sindec = sin (dec_r) + + theta = acos (sindec * W_SINDEC(wcs) + cosdec * W_COSDEC(wcs) * cosdra) + if (theta == 0.d0) + r = 1.d0 + else + r = theta / sin (theta) + + xi_r = r * cosdec * sindra + eta_r = r * (sindec * W_COSDEC(wcs) - cosdec * W_SINDEC(wcs) * cosdra) +end + + +# xt_pw_arc -- convert to ra & dec using arc projection +# The rectangular coordinates of the pixel on a unit celestial sphere +# are computed in a coordinate system such that the x-axis points toward +# the reference pixel, the y-axis is in the direction of increasing right +# ascension, and the z-axis is in the direction of increasing declination. +# The coordinate system is then rotated (around the y-axis) by the +# declination so the x-axis passes through the equator at the RA of the +# reference pixel; the components of the vector in this coordinate system +# are used to compute (RA - reference_RA) and declination. + +procedure xt_pw_arc (wcs, xi_r, eta_r, dra_r, dec_r) + +pointer wcs # i: pointer to world coord system struct +double xi_r # i: standard coordinate (radians) +double eta_r # i: standard coordinate (radians) +double dra_r # o: RA of object - RA at reference pixel (radians) +double dec_r # o: declination of object (radians) +#-- +double theta # arc length, i.e. sqrt (xi**2 + eta**2) +double v[3] # unit vector with v[1] pointing toward ref pixel +double x, y, z # vector with x[1] pointing toward equator + +begin + theta = sqrt (xi_r*xi_r + eta_r*eta_r) + if (theta == 0.d0) { + v[1] = 1.d0 + v[2] = 0.d0 + v[3] = 0.d0 + } else { + v[1] = cos (theta) + v[2] = sin (theta) / theta * xi_r + v[3] = sin (theta) / theta * eta_r + } + + # Rotate the rectangular coordinate system of the vector v by the + # declination so the x-axis will pass through the equator. + x = v[1] * W_COSDEC(wcs) - v[3] * W_SINDEC(wcs) + y = v[2] + z = v[1] * W_SINDEC(wcs) + v[3] * W_COSDEC(wcs) + + if (x == 0.d0 && y == 0.d0) + dra_r = 0.d0 + else + dra_r = atan2 (y, x) + dec_r = atan2 (z, sqrt (x*x + y*y)) +end + + +# xt_wp_ncp -- convert from ra & dec using ncp projection +# +# References: +# AIPS Memo No. 27 by Eric W. Greisen +# Data Processing for the Westerbork Synthesis Radio Telescope +# by W. N. Brouw + +procedure xt_wp_ncp (wcs, dra_r, dec_r, xi_r, eta_r) + +pointer wcs # i: pointer to world coord system struct +double dra_r # i: RA of object - RA at reference pixel (radians) +double dec_r # i: declination of object (radians) +double xi_r # o: standard coordinate (radians) +double eta_r # o: standard coordinate (radians) +#-- +double cosdra, sindra # cos & sin of delta_ra +double cosdec # cos of object declination + +begin + if (W_SINDEC(wcs) == 0.) + call error (1, "NCP projection: dec is zero") + + cosdra = cos (dra_r) + sindra = sin (dra_r) + + cosdec = cos (dec_r) + + xi_r = - cosdec * sindra + eta_r = (W_COSDEC(wcs) - cosdec * cosdra) / W_SINDEC(wcs) +end + + +# xt_pw_ncp -- convert to ra & dec using ncp projection +# +# References: +# AIPS Memo No. 27 by Eric W. Greisen +# Data Processing for the Westerbork Synthesis Radio Telescope +# by W. N. Brouw + +procedure xt_pw_ncp (wcs, xi_r, eta_r, dra_r, dec_r) + +pointer wcs # i: pointer to world coord system struct +double xi_r # i: standard coordinate (radians) +double eta_r # i: standard coordinate (radians) +double dra_r # o: RA of object - RA at reference pixel (radians) +double dec_r # o: declination of object (radians) +#-- +double temp + +begin + temp = W_COSDEC(wcs) - eta_r * W_SINDEC(wcs) + + dra_r = atan2 (-xi_r, temp) + dec_r = acos (temp / cos (dra_r)) + if (W_SINDEC(wcs) < 0) + dec_r = -dec_r +end + + +# xt_wp_gls -- convert from ra & dec using global-sine projection +# +# Reference: AIPS Memo No. 46 by Eric W. Greisen + +procedure xt_wp_gls (wcs, dra_r, dec_r, xi_r, eta_r) + +pointer wcs # i: pointer to world coord system struct +double dra_r # i: RA of object - RA at reference pixel (radians) +double dec_r # i: declination of object (radians) +double xi_r # o: standard coordinate (radians) +double eta_r # o: standard coordinate (radians) +#-- +double cosdec # cos of object declination +double temp # delta RA +int idec # which axis is declination axis + +begin + cosdec = cos (dec_r) + idec = W_DEC_AX(wcs) + + temp = dra_r + + # Put dra_r on the interval (-180,+180] degrees. + if (temp <= -PI) + temp = temp + TWOPI + if (temp > PI) + temp = temp - TWOPI + + xi_r = temp * cosdec + + if (idec > 0) + eta_r = dec_r - DEGTORAD (W_CRVAL(wcs,idec)) + else + eta_r = dec_r +end + + +# xt_pw_gls -- convert to ra & dec using global-sine projection +# +# Reference: AIPS Memo No. 46 by Eric W. Greisen + +procedure xt_pw_gls (wcs, xi_r, eta_r, dra_r, dec_r) + +pointer wcs # i: pointer to world coord system struct +double xi_r # i: standard coordinate (radians) +double eta_r # i: standard coordinate (radians) +double dra_r # o: RA of object - RA at reference pixel (radians) +double dec_r # o: declination of object (radians) +#-- +double cosdec # cosine of object declination +int idec # which axis is declination axis + +begin + idec = W_DEC_AX(wcs) + if (idec > 0) + dec_r = eta_r + DEGTORAD (W_CRVAL(wcs,idec)) + else + dec_r = eta_r + + cosdec = cos (dec_r) + if (cosdec > 0.d0) + dra_r = xi_r / cosdec + else + dra_r = 0.d0 +end + +# xt_wp_stg -- convert from ra & dec using stereographic projection +# +# Reference: AIPS Memo No. 46 by Eric W. Greisen + +procedure xt_wp_stg (wcs, dra_r, dec_r, xi_r, eta_r) + +pointer wcs # i: pointer to world coord system struct +double dra_r # i: RA of object - RA at reference pixel (radians) +double dec_r # i: declination of object (radians) +double xi_r # o: standard coordinate (radians) +double eta_r # o: standard coordinate (radians) +#-- +double cosdra, sindra # cos & sin of dra_r +double cosdec, sindec # cos & sin of object declination +double cosdist # cos of dist from ref pixel to object +double sincos # sin (theta) * cos (phi) + +begin + cosdra = cos (dra_r) + sindra = sin (dra_r) + + cosdec = cos (dec_r) + sindec = sin (dec_r) + + cosdist = sindec * W_SINDEC(wcs) + cosdec * W_COSDEC(wcs) * cosdra + sincos = sindec * W_COSDEC(wcs) - cosdec * W_SINDEC(wcs) * cosdra + + xi_r = 2.d0 * cosdec * sindra / (1.d0 + cosdist) + eta_r = 2.d0 * sincos / (1.d0 + cosdist) +end + + +# xt_pw_stg -- convert to ra & dec using stereographic projection + +procedure xt_pw_stg (wcs, xi_r, eta_r, dra_r, dec_r) + +pointer wcs # i: pointer to world coord system struct +double xi_r # i: standard coordinate (radians) +double eta_r # i: standard coordinate (radians) +double dra_r # o: RA of object - RA at reference pixel (radians) +double dec_r # o: declination of object (radians) +#-- +double rho2 # square of distance from reference pixel +double scale # factor to reduce xi, eta to y, z +double x, y, z # unit vector toward object +double temp + +begin + rho2 = xi_r * xi_r + eta_r * eta_r + + x = (4.d0 - rho2) / (4.d0 + rho2) + scale = (x + 1.d0) / 2.d0 + + y = xi_r * scale + z = eta_r * scale + + temp = x * W_COSDEC(wcs) - z * W_SINDEC(wcs) + z = x * W_SINDEC(wcs) + z * W_COSDEC(wcs) + x = temp + + if (x == 0.d0 && y == 0.d0) + dra_r = 0.d0 + else + dra_r = atan2 (y, x) + dec_r = atan2 (z, sqrt (x*x + y*y)) +end + + +# xt_wp_ait -- convert from ra & dec using Aitoff projection +# +# Note that the declination at the reference pixel is ignored and is +# assumed to be zero. The algorithms given in the AIPS reference do +# allow for a non-zero declination at the reference pixel. +# +# Reference: AIPS Memo No. 46 by Eric W. Greisen + +procedure xt_wp_ait (wcs, dra_r, dec_r, xi_r, eta_r) + +pointer wcs # i: pointer to world coord system struct +double dra_r # i: RA of object - RA at reference pixel (radians) +double dec_r # i: declination of object (radians) +double xi_r # o: standard coordinate (radians) +double eta_r # o: standard coordinate (radians) +#-- +double z # temp variable +double cosdec # cosine of declination + +begin + cosdec = cos (dec_r) + z = sqrt ((1.d0 + cosdec * cos (dra_r/2.d0)) / 2.d0) + + xi_r = 2.d0 * cosdec * sin (dra_r/2.d0) / z + eta_r = sin (dec_r) / z +end + + +# xt_pw_ait -- convert to ra & dec using Aitoff projection +# +# Note that the declination at the reference pixel is ignored and is +# assumed to be zero. The algorithms given in the AIPS reference do +# allow for a non-zero declination at the reference pixel. +# +# Reference: AIPS Memo No. 46 by Eric W. Greisen + +procedure xt_pw_ait (wcs, xi_r, eta_r, dra_r, dec_r) + +pointer wcs # i: pointer to world coord system struct +double xi_r # i: standard coordinate (radians) +double eta_r # i: standard coordinate (radians) +double dra_r # o: RA of object - RA at reference pixel (radians) +double dec_r # o: declination of object (radians) +#-- +double z # temp variable +double cosdec # cosine of declination + +begin + z = sqrt (1.d0 - xi_r*xi_r/16.d0 - eta_r*eta_r/4.d0) + + dec_r = asin (eta_r * z) + cosdec = cos (dec_r) + + if (cosdec > 0.d0) { + dra_r = 2.d0 * asin (xi_r * z / (2.d0 * cosdec)) + } else { + dra_r = 0.d0 + } +end + + +# xt_wp_mer -- convert from ra & dec using Mercator projection +# +# Note that the declination at the reference pixel is ignored and is +# assumed to be zero. The algorithms given in the AIPS reference do +# allow for a non-zero declination at the reference pixel. +# +# Reference: AIPS Memo No. 46 by Eric W. Greisen + +procedure xt_wp_mer (wcs, dra_r, dec_r, xi_r, eta_r) + +pointer wcs # i: pointer to world coord system struct +double dra_r # i: RA of object - RA at reference pixel (radians) +double dec_r # i: declination of object (radians) +double xi_r # o: standard coordinate (radians) +double eta_r # o: standard coordinate (radians) +#-- +double temp + +begin + xi_r = dra_r + temp = (dec_r + HALFPI) / 2.d0 + if (temp >= HALFPI || temp <= 0.d0) + call error (1, "invalid declination for Mercator projection") + eta_r = log (tan (temp)) +end + + +# xt_pw_mer -- convert to ra & dec using Mercator projection +# +# Reference: AIPS Memo No. 46 by Eric W. Greisen + +procedure xt_pw_mer (wcs, xi_r, eta_r, dra_r, dec_r) + +pointer wcs # i: pointer to world coord system struct +double xi_r # i: standard coordinate (radians) +double eta_r # i: standard coordinate (radians) +double dra_r # o: RA of object - RA at reference pixel (radians) +double dec_r # o: declination of object (radians) +#-- + +begin + dra_r = xi_r + dec_r = 2.d0 * atan (exp (eta_r)) - HALFPI +end diff --git a/pkg/utilities/nttools/tabim.par b/pkg/utilities/nttools/tabim.par new file mode 100644 index 00000000..f7188f5f --- /dev/null +++ b/pkg/utilities/nttools/tabim.par @@ -0,0 +1,11 @@ +intable,s,a,"",,,"input table" +output,s,a,"",,,"output image" +colname,s,a,"",,,"column name" +ndim,i,a,1,0,7,"dimension of image" +n1,i,a,1,1,,"size of first axis" +n2,i,a,1,1,,"size of second axis" +n3,i,a,1,1,,"size of third axis" +n4,i,a,1,1,,"size of fourth axis" +n5,i,a,1,1,,"size of fifth axis" +n6,i,a,1,1,,"size of sixth axis" +mode,s,h,"al" diff --git a/pkg/utilities/nttools/tabkey.par b/pkg/utilities/nttools/tabkey.par new file mode 100644 index 00000000..57168a7b --- /dev/null +++ b/pkg/utilities/nttools/tabkey.par @@ -0,0 +1,7 @@ +table,f,a,"",,,"Name of table" +column,s,a,"",,,"Name of column" +row,i,a,,1,,"Number of row" +output,f,a,"",,,"Name of file containing header keyword" +keyword,s,a,"",,,"Name of header keyword" +add,b,h,no,,,"Is it OK to create a new keyword?" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/tabpar.par b/pkg/utilities/nttools/tabpar.par new file mode 100644 index 00000000..496ec498 --- /dev/null +++ b/pkg/utilities/nttools/tabpar.par @@ -0,0 +1,7 @@ +table,f,a,"",,,"Name of table" +column,s,a,"",,,"Name of column" +row,i,a,,1,,"Number of row" +format,b,h,yes,,,"Format the value using table print format?" +value,s,h,"",,,"Value of table element" +undef,b,h,,,,"Is table element undefined?" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/tabvar.com b/pkg/utilities/nttools/tabvar.com new file mode 100644 index 00000000..417e75d4 --- /dev/null +++ b/pkg/utilities/nttools/tabvar.com @@ -0,0 +1,9 @@ +# TCALC.COM -- Common block used for comunicating btw tcalc and tabvar + +double nullval # Substituted for null columns in expressions +pointer tabptr # Table descriptor +int firstrow # First row to evaluate +int lastrow # Last row to evaluate + +common /tcalc/ nullval, tabptr, firstrow, lastrow + diff --git a/pkg/utilities/nttools/taextract.par b/pkg/utilities/nttools/taextract.par new file mode 100644 index 00000000..ca8a6704 --- /dev/null +++ b/pkg/utilities/nttools/taextract.par @@ -0,0 +1,10 @@ +intable,s,a,"",,,"name of input table" +outtable,s,a,"",,,"name of output table" +row,i,a,,1,,"input row number" +column,s,a,"",,,"column name" +outcolumn,s,a,"",,,"name to use for column in output table" +datatype,s,h,"",,,"data type for new column" +colunits,s,h,"",,,"units for new column" +colfmt,s,h,"",,,"print format for new column" +Version,s,h,"30Jan1998",,,"date of installation" +mode,s,h,"al" diff --git a/pkg/utilities/nttools/tainsert.par b/pkg/utilities/nttools/tainsert.par new file mode 100644 index 00000000..d6b24194 --- /dev/null +++ b/pkg/utilities/nttools/tainsert.par @@ -0,0 +1,11 @@ +intable,s,a,"",,,"name of input table" +outtable,s,a,"",,,"name of output table" +row,i,a,-1,,,"output row number" +column,s,a,"",,,"column name" +outcolumn,s,a,"",,,"name to use for column in output table" +size,i,h,INDEF,,,"length of array in output table" +datatype,s,h,"",,,"data type for new column" +colunits,s,h,"",,,"units for new column" +colfmt,s,h,"",,,"print format for new column" +Version,s,h,"30Jan1998",,,"date of installation" +mode,s,h,"al" diff --git a/pkg/utilities/nttools/tcalc.par b/pkg/utilities/nttools/tcalc.par new file mode 100644 index 00000000..b3ae6977 --- /dev/null +++ b/pkg/utilities/nttools/tcalc.par @@ -0,0 +1,7 @@ +table,f,a,,,,"Input table" +outcol,s,a,,,,"Output column name" +equals,s,a,,"",,"Arithmetic expression" +datatype,s,h,"real","real|double|short|int",,"Output column data type, if new column" +colunits,s,h,"",,,"Units for output column" +colfmt,s,h,"",,,"Display format for output column" +mode,s,h,al diff --git a/pkg/utilities/nttools/tcalc/mkpkg b/pkg/utilities/nttools/tcalc/mkpkg new file mode 100644 index 00000000..d2fa96b9 --- /dev/null +++ b/pkg/utilities/nttools/tcalc/mkpkg @@ -0,0 +1,11 @@ +# Update the tcalc application code in the ttools package library +# Author: Bernie Simon, 04-Nov-91 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + tcalc.x "../tabvar.com" + ; diff --git a/pkg/utilities/nttools/tcalc/tcalc.x b/pkg/utilities/nttools/tcalc/tcalc.x new file mode 100644 index 00000000..854df2e3 --- /dev/null +++ b/pkg/utilities/nttools/tcalc/tcalc.x @@ -0,0 +1,132 @@ +include +define HARMLESS 0.1d0 +define MAXROWS 10000 + +# T_TCALC -- perform arithmetic operation on columns of a table +# +# B.Simon 03-May-91 Original +# B.Simon 24-Jun-97 Long columns done in pieces +# B.Simon 16-Jul-97 Error message for string columns +# B.Simon 30-Mar-00 Allow wild cards in table names + +procedure t_tcalc() + +#-- +pointer table # input/output table name +pointer outcol # output column +pointer equals # expression +pointer colunits # output col units +pointer colfmt # output col format +pointer datatype # output col datatype + +include "../tabvar.com" + +bool done +double nil +pointer sp, tp, list, buffer, colptr, code +int nrows, nbuf, coltype, exptype + +string badtype "Invalid data type for output column" + +int tbnget(), tbpsta(), tbcigi() +pointer tbnopenp(), tbtopn(), vex_compile() + +extern tabvar + +begin + call smark (sp) + call salloc (table, SZ_FNAME, TY_CHAR) + call salloc (outcol, SZ_FNAME, TY_CHAR) + call salloc (equals, SZ_FNAME, TY_CHAR) + call salloc (datatype, SZ_FNAME, TY_CHAR) + call salloc (colunits, SZ_FNAME, TY_CHAR) + call salloc (colfmt, SZ_FNAME, TY_CHAR) + + list = tbnopenp ("table") + call clgstr ("outcol", Memc[outcol], SZ_FNAME) + call clgstr ("equals", Memc[equals], SZ_FNAME) + + code = vex_compile (Memc[equals]) + + while (tbnget (list, Memc[table], SZ_FNAME) != EOF) { + tp = tbtopn (Memc[table], READ_WRITE, 0) + nrows = tbpsta (tp, TBL_NROWS) + + call tbcfnd (tp, Memc[outcol], colptr, 1) + if (colptr != NULL) { + coltype = tbcigi (colptr, TBL_COL_DATATYPE) + + } else { + call clgstr ("datatype", Memc[datatype], SZ_FNAME) + call clgstr ("colunits", Memc[colunits], SZ_FNAME) + call clgstr ("colfmt" , Memc[colfmt], SZ_FNAME) + + switch (Memc[datatype]) { + case 'r': + coltype = TY_REAL + case 'd': + coltype = TY_DOUBLE + case 's': + coltype = TY_SHORT + case 'i': + coltype = TY_INT + default: + call tbtclo (tp) + call error (1, badtype) + } + + call tbbftp (Memc[colfmt], Memc[colfmt]) + call tbcdef (tp, colptr, Memc[outcol], Memc[colunits], + Memc[colfmt], coltype, 1, 1) + } + + # Initialize common block used by tabvar() + + tabptr = tp + firstrow = 1 + lastrow = MAXROWS + nullval = HARMLESS + + done = false + nil = HARMLESS + + repeat { + if (lastrow >= nrows) { + done = true + lastrow = nrows + } + + nbuf = (lastrow - firstrow) + 1 + call vex_eval (code, tabvar, nil, exptype) + + switch (coltype) { + case TY_SHORT, TY_INT, TY_LONG: + call malloc (buffer, nbuf, TY_INT) + call vex_copyi (code, INDEFI, Memi[buffer], nbuf) + call tbcpti (tp, colptr, Memi[buffer], firstrow, lastrow) + call mfree (buffer, TY_INT) + case TY_REAL: + call malloc (buffer, nbuf, TY_REAL) + call vex_copyr (code, INDEFR, Memr[buffer], nbuf) + call tbcptr (tp, colptr, Memr[buffer], firstrow, lastrow) + call mfree (buffer, TY_REAL) + case TY_DOUBLE: + call malloc (buffer, nbuf, TY_DOUBLE) + call vex_copyd (code, INDEFD, Memd[buffer], nbuf) + call tbcptd (tp, colptr, Memd[buffer], firstrow, lastrow) + call mfree (buffer, TY_DOUBLE) + default: + call tbtclo (tp) + call error (1, badtype) + } + + firstrow = firstrow + MAXROWS + lastrow = lastrow + MAXROWS + } until (done) + + call tbtclo(tp) + } + + call vex_free (code) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tchcol.par b/pkg/utilities/nttools/tchcol.par new file mode 100644 index 00000000..9dc14a99 --- /dev/null +++ b/pkg/utilities/nttools/tchcol.par @@ -0,0 +1,7 @@ +table,s,a,"",,,"tables to be modified in-place" +oldname,s,a,"",,,"current column name" +newname,s,a,"",,,"new column name, or null" +newfmt,s,a,"",,,"new print format for column, or null" +newunits,s,a,"",,,"new column units, or null" +verbose,b,h,yes,,,"print operations performed?" +mode,s,h,"al" diff --git a/pkg/utilities/nttools/tchcol/mkpkg b/pkg/utilities/nttools/tchcol/mkpkg new file mode 100644 index 00000000..dce427be --- /dev/null +++ b/pkg/utilities/nttools/tchcol/mkpkg @@ -0,0 +1,20 @@ +# MKPKG file for the tchcol task +# Author: J.-C. Hsu 08-Dec-87 +# +# Special keywords recognized by standard SDAS mkpkg files: +# +# mkpkg debug=yes link ttools executable with the debugger +# mkpkg linkonly skip ttools library update and just link + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +linkonly: + $call linkonly@.. + ; + +libpkg.a: + tchcol.x + ; diff --git a/pkg/utilities/nttools/tchcol/tchcol.x b/pkg/utilities/nttools/tchcol/tchcol.x new file mode 100644 index 00000000..c7a1c985 --- /dev/null +++ b/pkg/utilities/nttools/tchcol/tchcol.x @@ -0,0 +1,162 @@ +include # for IS_WHITE +include + +# tchcol -- change column information +# This task can be used to change the name, print format, and/or units +# for one column of a list of tables. If any of the new values is null +# or blank, the value will not be changed. If the value is "default" +# for format or units, the value will be changed to the default. +# For units the default is null. +# +# J.-C. HSU, 11-Jul-1987 design and coding +# Phil Hodge, 15-Mar-1989 rewrite in spp +# Phil Hodge, 10-Apr-1990 change SZ_COLNAME to SZ_FNAME, etc for clgstr +# Phil Hodge, 10-May-1991 allow multiple input tables; +# use "default" to set format or units to the default +# Phil Hodge, 18-Jun-1993 preserve case of newfmt to allow e.g. %12.1H +# Phil Hodge, 11-Aug-1993 print warning if text table and user has +# requested a change of column name or units +# Phil Hodge, 3-Oct-1995 Modify to use tbn instead of fnt. +# Phil Hodge, 7-Jun-1999 Delete warning messages for text tables +# (this undoes the change made on 11-Aug-1993). +# Phil Hodge, 30-Sep-1999 Remove trailing blanks from new name, units, format. + +procedure tchcol() + +pointer tp # pointer to table descriptor +pointer cp # pointer to column descriptor +pointer ilist # for list of tables to change +char table[SZ_FNAME] # table name +char oldname[SZ_COLNAME] # column name before being changed +char newname[SZ_COLNAME] # new column name or "" +char oldfmt[SZ_COLFMT] # print format before being changed +char newfmt[SZ_COLFMT] # new column print format or "default" +char newf[SZ_COLFMT] # new spp style print format or "" +char oldunits[SZ_COLUNITS] # column units before being changed +char newunits[SZ_COLUNITS] # new column units or "default" +char newu[SZ_COLUNITS] # new column units or "" +char newval[SZ_COLUNITS] # actual new value of format or units in table +bool verbose # if true, tell user what's happening +int i, strlen() # for stripping off trailing blanks +pointer tbtopn() +pointer tbnopenp() +int tbnget() +bool clgetb(), streq() + +begin + ilist = tbnopenp ("table") + call clgstr ("oldname", oldname, SZ_COLNAME) + call clgstr ("newname", newname, SZ_COLNAME) + call clgstr ("newfmt", newfmt, SZ_COLFMT) + call clgstr ("newunits", newunits, SZ_COLUNITS) + verbose = clgetb ("verbose") + + # Remove leading whitespace from new values. + call xt_stripwhite (newname) + call xt_stripwhite (newfmt) + call xt_stripwhite (newunits) + + # Remove trailing whitespace from new values. + do i = strlen (newname), 1, -1 { + if (IS_WHITE(newname[i])) + newname[i] = EOS + else + break + } + do i = strlen (newfmt), 1, -1 { + if (IS_WHITE(newfmt[i])) + newfmt[i] = EOS + else + break + } + do i = strlen (newunits), 1, -1 { + if (IS_WHITE(newunits[i])) + newunits[i] = EOS + else + break + } + + if (newname[1] == EOS && newfmt[1] == EOS && newunits[1] == EOS) { + call eprintf ("no change specified\n") + call tbnclose (ilist) + return + } + + # Check for "default" for format or units, and copy to newf & newu. + + call strcpy (newfmt, newf, SZ_COLFMT) + call strlwr (newf) # preserve case of newfmt + if (streq (newf, "default")) + newf[1] = EOS + else + call tbbftp (newfmt, newf) # convert from Fortran style + + call strcpy (newunits, newu, SZ_COLUNITS) + call strlwr (newu) + if (streq (newu, "default")) + newu[1] = EOS + else + call strcpy (newunits, newu, SZ_COLUNITS) # preserve case + + # Process all the tables in the list. + while (tbnget (ilist, table, SZ_FNAME) != EOF) { + + if (verbose) { + call printf ("table %s\n") + call pargstr (table) + } + + tp = tbtopn (table, READ_WRITE, NULL) + + call tbcfnd (tp, oldname, cp, 1) + if (cp == NULL) { + call tbtclo (tp) + if ( ! verbose ) { + call printf ("table %s\n") + call pargstr (table) + } + call printf (" warning: column `%s' not found\n") + call pargstr (oldname) + next + } + + if (newname[1] != EOS) { + call tbcnam (tp, cp, newname) + if (verbose) { + call printf (" column name changed from `%s' to `%s'\n") + call pargstr (oldname) + call pargstr (newname) + } + } + + # newf may be EOS even if newfmt is not. + if (newfmt[1] != EOS) { + call tbcigt (cp, TBL_COL_FMT, oldfmt, SZ_COLFMT) + call tbcfmt (tp, cp, newf) + if (verbose) { + call tbcigt (cp, TBL_COL_FMT, newval, SZ_COLUNITS) + call printf (" print format changed from `%s' to `%s'\n") + call pargstr (oldfmt) + call pargstr (newval) + } + } + + # newu may be EOS even if newunits is not. + if (newunits[1] != EOS) { + call tbcigt (cp, TBL_COL_UNITS, oldunits, SZ_COLUNITS) + call tbcnit (tp, cp, newu) + if (verbose) { + call tbcigt (cp, TBL_COL_UNITS, newval, SZ_COLUNITS) + call printf (" column units changed from `%s' to `%s'\n") + call pargstr (oldunits) + call pargstr (newval) + } + } + + call tbtclo (tp) + + if (verbose) # added 8/11/93 + call flush (STDOUT) + } + call tbnclose (ilist) +end diff --git a/pkg/utilities/nttools/tcheck.par b/pkg/utilities/nttools/tcheck.par new file mode 100644 index 00000000..4304221c --- /dev/null +++ b/pkg/utilities/nttools/tcheck.par @@ -0,0 +1,3 @@ +input,s,a,,,,Table name(s) +chkfile,s,a,,,,Text file containing consistency checks +mode, s, h, 'a',,, diff --git a/pkg/utilities/nttools/tcheck/cmdsplit.x b/pkg/utilities/nttools/tcheck/cmdsplit.x new file mode 100644 index 00000000..7fa7e714 --- /dev/null +++ b/pkg/utilities/nttools/tcheck/cmdsplit.x @@ -0,0 +1,57 @@ +include "tcheck.h" + +# CMDSPLIT -- Split a command into keyword and expression strings + +procedure cmdsplit (command, keystart, cmdstart) + +char command[ARB] # io: Command line +int keystart # o: Start of keyword substring +int cmdstart # o: Start of command substring +#-- +char comment +int ic, jc +pointer sp, keyword + +data comment / '#' / + +string noexpress "No expression following when" + +bool streq() +int stridx(), word_fetch() + +begin + call smark (sp) + call salloc (keyword, SZ_FNAME, TY_CHAR) + + # Strip comments from command line + + ic = stridx (comment, command) + if (ic > 0) + command[ic] = EOS + + # Set output variables to default values + + keystart = 1 + cmdstart = 0 + + # Find location of "when" in command and split the line there + + ic = 1 + jc = 0 + while (word_fetch (command, ic, Memc[keyword], SZ_FNAME) > 0) { + if (jc > 0 && streq (Memc[keyword], "when")) { + command[jc] = EOS + cmdstart = ic + break + } + jc = ic + } + + # Exit with error if no expression was found + + if (cmdstart == 0 && jc > 0) + call error (SYNTAX, noexpress) + + call sfree (sp) +end + diff --git a/pkg/utilities/nttools/tcheck/mkpkg b/pkg/utilities/nttools/tcheck/mkpkg new file mode 100644 index 00000000..a5a0812b --- /dev/null +++ b/pkg/utilities/nttools/tcheck/mkpkg @@ -0,0 +1,13 @@ +# Update the tcheck application code in the ttools package library +# Author: B.Simon, 22-AUG-1990 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + cmdsplit.x "tcheck.h" + tcheck.x "tcheck.h" + wrtcheck.x + ; diff --git a/pkg/utilities/nttools/tcheck/tcheck.h b/pkg/utilities/nttools/tcheck/tcheck.h new file mode 100644 index 00000000..6f08cede --- /dev/null +++ b/pkg/utilities/nttools/tcheck/tcheck.h @@ -0,0 +1,4 @@ +# TCHECK.H -- Symbolic constants used by tcheck + +define SYNTAX 1 # Syntax errors in evexpr + diff --git a/pkg/utilities/nttools/tcheck/tcheck.x b/pkg/utilities/nttools/tcheck/tcheck.x new file mode 100644 index 00000000..e23408e0 --- /dev/null +++ b/pkg/utilities/nttools/tcheck/tcheck.x @@ -0,0 +1,91 @@ +include +include "tcheck.h" + +# TCHECK -- Perform a consistency check on the rows of a table +# +# B.Simon 20-Aug-90 Original +# B.Simon 29-Jul-92 Fixed bug occuring when irow > nrow +# Phil Hodge 4-Oct-95 Use table name template routines tbnopenp, etc. + +procedure tcheck () + +#-- +pointer input # Table file name template +pointer chkfile # Text file containing consistency checks + +bool title +int fd, iline, nc +int keystart, cmdstart, irow, jrow, nrow +pointer sp, tabname, errmsg, command, tp + +string badexpr "Syntax error: %s" + +int open(), tbnget(), getlongline() +int tbpsta(), strlen(), tbl_search() +pointer tbnopenp(), tbtopn() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (chkfile, SZ_FNAME, TY_CHAR) + call salloc (tabname, SZ_FNAME, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + call salloc (command, SZ_COMMAND, TY_CHAR) + + # Read the task parameters + + input = tbnopenp ("input") + call clgstr ("chkfile", Memc[chkfile], SZ_FNAME) + + fd = open (Memc[chkfile], READ_ONLY, TEXT_FILE) + + # Check each table + + while (tbnget (input, Memc[tabname], SZ_FNAME) != EOF) { + call seek (fd, BOF) + tp = tbtopn (Memc[tabname], READ_ONLY, NULL) + nrow = tbpsta (tp, TBL_NROWS) + title = true + + # Get each line from the command file + + repeat { + nc = getlongline (fd, Memc[command], SZ_COMMAND, iline) + if (nc <= 0) + break + + Memc[command+nc-1] = EOS + call cmdsplit (Memc[command], keystart, cmdstart) + if (cmdstart > 0) { + irow = 1 + while (irow <= nrow) { + jrow = tbl_search (tp, Memc[command+cmdstart-1], + irow, nrow) + if (jrow == 0) { + break + + } else if (jrow == ERR) { + call xer_reset + if (strlen (Memc[command+cmdstart-1]) > 60) + call strcat (" ...", Memc[command+cmdstart+60], + SZ_COMMAND) + + call sprintf (Memc[errmsg], SZ_LINE, badexpr) + call pargstr (Memc[command+cmdstart-1]) + call error (SYNTAX, Memc[errmsg]) + + } else { + call wrt_check (tp, jrow, Memc[command+keystart-1], + Memc[command+cmdstart-1], title) + irow = jrow + 1 + } + } + } + } + call tbtclo (tp) + } + + call tbnclose (input) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tcheck/wrtcheck.x b/pkg/utilities/nttools/tcheck/wrtcheck.x new file mode 100644 index 00000000..b14ec542 --- /dev/null +++ b/pkg/utilities/nttools/tcheck/wrtcheck.x @@ -0,0 +1,61 @@ +# WRT_CHECK -- Write the table values that pass the check + +procedure wrt_check (tp, irow, keylist, command, title) + +pointer tp # i: Table descriptor +int irow # i: Table row number +char keylist[ARB] # i: List of keywords to print +char command[ARB] # io: Expression used in check +bool title # io: Print title? +#-- +int ic +pointer sp, tabname, ldir, keyword, newcmd, value, root, col + +int fnldir(), gstrcpy(), word_fetch() + +begin + call smark (sp) + call salloc (tabname, SZ_FNAME, TY_CHAR) + call salloc (ldir, SZ_FNAME, TY_CHAR) + call salloc (keyword, SZ_FNAME, TY_CHAR) + call salloc (newcmd, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_LINE, TY_CHAR) + + # Print title if this is the first error found in this table + + if (title) { + title = false + call tbtnam (tp, Memc[tabname], SZ_FNAME) + root = tabname + fnldir (Memc[tabname], Memc[ldir], SZ_FNAME) + + call printf ("#\n#%11t%-60s\n#\n") + call pargstr (Memc[root]) + } + + # Truncate command to 60 characters + + if (gstrcpy (command, Memc[newcmd], 60) == 60) + call strcat (" ...", Memc[newcmd], SZ_FNAME) + + # Print each keyword name, value, and associated command + + ic = 1 + while (word_fetch (keylist, ic, Memc[keyword], SZ_FNAME) > 0) { + call tbcfnd (tp, Memc[keyword], col, 1) + if (col != NULL) { + call tbegtt (tp, col, irow, Memc[value], SZ_LINE) + + call printf ("%-5d%-20s%-20s%-30s\n") + call pargi (irow) + call pargstr (Memc[keyword]) + call pargstr (Memc[value]) + call pargstr (Memc[newcmd]) + + } else { + call printf ("%-5d%-20s missing\n") + call pargi (irow) + call pargstr (Memc[keyword]) + } + } + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tchsize.par b/pkg/utilities/nttools/tchsize.par new file mode 100644 index 00000000..24e1d013 --- /dev/null +++ b/pkg/utilities/nttools/tchsize.par @@ -0,0 +1,8 @@ +intable,s,a,"",,,"input tables" +outtable,s,a,"",,,"output tables or directory" +maxpar,i,a,-1,,,"new maximum number of header parameters" +maxcols,i,a,-1,,,"new maximum space for column descriptors" +rowlen,i,a,-1,,,"new row length" +allrows,i,a,-1,,,"new allocated number of rows" +verbose,b,h,yes,,,"print operations performed?" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/tchsize/mkpkg b/pkg/utilities/nttools/tchsize/mkpkg new file mode 100644 index 00000000..3459a3f5 --- /dev/null +++ b/pkg/utilities/nttools/tchsize/mkpkg @@ -0,0 +1,11 @@ +# Update the tchsize application code in the ttools package library +# Author: HODGE, 2-FEB-1988 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + tchsize.x + ; diff --git a/pkg/utilities/nttools/tchsize/tchsize.x b/pkg/utilities/nttools/tchsize/tchsize.x new file mode 100644 index 00000000..89a53293 --- /dev/null +++ b/pkg/utilities/nttools/tchsize/tchsize.x @@ -0,0 +1,173 @@ +include + +# tchsize -- Change size of table(s) + +# The input tables are given by an filename template list. The output +# is either a matching list of tables or a directory. The number of +# input tables may be either one or match the number of output tables. +# This is based on the t_imcopy procedure. +# +# NOTE: If task is used on a FITS table, it will be skipped. +# +# Phil Hodge, 28-Aug-1987 Task created. +# Phil Hodge, 7-Sep-1988 Change parameter names for tables. +# Phil Hodge, 26-Mar-1992 Remove calls to tbtext. +# Phil Hodge, 3-Oct-1995 Modify to use tbn instead of fnt; check for FITS. +# Phil hodge, 16-Apr-1999 Call tbttyp instead of tbparse. + +procedure tchsize() + +char tablist1[SZ_LINE] # Input table list +char tablist2[SZ_LINE] # Output table list +bool verbose # Print operations? +int maxpar # new max number of user (header) parameters +int maxcols # new max space for column descriptors +int rowlen # new row length (for row-ordered tables) +int allrows # new allocated number of rows (for col-ordered) +#-- +int ttype, exists, tbttyp() # to check for a FITS table (exists is ignored) + +pointer tp # Pointer to table descriptor +char table1[SZ_PATHNAME] # Input table name +char table2[SZ_PATHNAME] # Output table name +char dirname1[SZ_PATHNAME] # Directory name +char dirname2[SZ_PATHNAME] # Directory name + +pointer list1, list2 +int root_len + +pointer tbtopn() +pointer tbnopen() +int tbnget(), tbnlen() +int fnldir(), isdirectory() +int clgeti() +bool clgetb(), streq() + +begin + # Get input and output table template lists. + call clgstr ("intable", tablist1, SZ_LINE) + call clgstr ("outtable", tablist2, SZ_LINE) + + # Get new values of table size parameters. + maxpar = clgeti ("maxpar") + maxcols = clgeti ("maxcols") + rowlen = clgeti ("rowlen") * SZ_REAL + allrows = clgeti ("allrows") + + verbose = clgetb ("verbose") + + # Check whether the output string is blank. + if (tablist2[1] == EOS) { + + # Expand the input table list, and change the sizes in-place. + list1 = tbnopen (tablist1) + + while (tbnget (list1, table1, SZ_PATHNAME) != EOF) { + + # Check for a FITS table. + ttype = tbttyp (table1, exists) + if (ttype == TBL_TYPE_FITS) { + call eprintf ("Skipping FITS table %s\n") + call pargstr (table1) + next + } + + if (verbose) { + call printf ("%s\n") + call pargstr (table1) + call flush (STDOUT) + } + # Open the table, change its size, and close it. + tp = tbtopn (table1, READ_WRITE, 0) + call tbtchs (tp, maxpar, maxcols, rowlen, allrows) + call tbtclo (tp) + } + call tbnclose (list1) + + # Check whether the output string is a directory. + } else if (isdirectory (tablist2, dirname2, SZ_PATHNAME) > 0) { + + list1 = tbnopen (tablist1) + while (tbnget (list1, table1, SZ_PATHNAME) != EOF) { + + ttype = tbttyp (table1, exists) + if (ttype == TBL_TYPE_FITS) { + call eprintf ("Skipping FITS table %s\n") + call pargstr (table1) + next + } + + # Place the input table name without a directory in + # string dirname1. + + call get_root (table1, table2, SZ_PATHNAME) + root_len = fnldir (table2, dirname1, SZ_PATHNAME) + call strcpy (table2[root_len + 1], dirname1, SZ_PATHNAME) + + call strcpy (dirname2, table2, SZ_PATHNAME) + call strcat (dirname1, table2, SZ_PATHNAME) + + if (verbose) { + call printf ("%s -> %s\n") + call pargstr (table1) + call pargstr (table2) + call flush (STDOUT) + } + # Copy the table, open it, change its size, and close it. + call tbtcpy (table1, table2) + tp = tbtopn (table2, READ_WRITE, 0) + call tbtchs (tp, maxpar, maxcols, rowlen, allrows) + call tbtclo (tp) + } + call tbnclose (list1) + + } else { + + # Expand the input and output table lists. + + list1 = tbnopen (tablist1) + list2 = tbnopen (tablist2) + + if (tbnlen (list1) != tbnlen (list2)) { + call tbnclose (list1) + call tbnclose (list2) + call error (1, "Number of input and output tables not the same") + } + + # Change each table in the list. + + while ((tbnget (list1, table1, SZ_PATHNAME) != EOF) && + (tbnget (list2, table2, SZ_PATHNAME) != EOF)) { + + ttype = tbttyp (table1, exists) + if (ttype == TBL_TYPE_FITS) { + call eprintf ("Skipping FITS table: %s --> %s\n") + call pargstr (table1) + call pargstr (table2) + next + } + + if (streq (table1, table2)) { + # Same input and output names; no need to copy the table. + if (verbose) { + call eprintf ("%s\n") + call pargstr (table1) + } + } else { + # Different input & output names, so copy the table. + if (verbose) { + call eprintf ("%s -> %s\n") + call pargstr (table1) + call pargstr (table2) + } + call tbtcpy (table1, table2) + } + # Open the table, change its size, and close it. + tp = tbtopn (table2, READ_WRITE, 0) + call tbtchs (tp, maxpar, maxcols, rowlen, allrows) + call tbtclo (tp) + } + call tbnclose (list1) + call tbnclose (list2) + } +end diff --git a/pkg/utilities/nttools/tcopy.par b/pkg/utilities/nttools/tcopy.par new file mode 100644 index 00000000..89059199 --- /dev/null +++ b/pkg/utilities/nttools/tcopy.par @@ -0,0 +1,4 @@ +intable,s,a,"",,,"input tables" +outtable,s,a,"",,,"output tables or directory" +verbose,b,h,yes,,,"print operations performed?" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/tcopy/iswholetab.x b/pkg/utilities/nttools/tcopy/iswholetab.x new file mode 100644 index 00000000..a2a981ed --- /dev/null +++ b/pkg/utilities/nttools/tcopy/iswholetab.x @@ -0,0 +1,24 @@ +# IS_WHOLETAB -- Return true if table name has no extension + +bool procedure is_wholetab (table) + +char table[ARB] # i: table name +#-- +bool wholetab +int nc, hdu +pointer sp, fname, extname + +int tbparse() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (extname, SZ_FNAME, TY_CHAR) + + nc = tbparse (table, Memc[fname], Memc[extname], SZ_FNAME, hdu) + + wholetab = Memc[extname] == EOS + + call sfree (sp) + return (wholetab) +end diff --git a/pkg/utilities/nttools/tcopy/mkpkg b/pkg/utilities/nttools/tcopy/mkpkg new file mode 100644 index 00000000..69ef0524 --- /dev/null +++ b/pkg/utilities/nttools/tcopy/mkpkg @@ -0,0 +1,13 @@ +# Update the tcopy application code in the ttools package library +# Author: HODGE, 2-FEB-1988 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + iswholetab.x + tcopy.x + tdelete.x + ; diff --git a/pkg/utilities/nttools/tcopy/tcopy.x b/pkg/utilities/nttools/tcopy/tcopy.x new file mode 100644 index 00000000..20713f26 --- /dev/null +++ b/pkg/utilities/nttools/tcopy/tcopy.x @@ -0,0 +1,283 @@ +include +include # used to check whether input or output is redirected +include + +# tcopy -- Copy table(s) + +# The input tables are given by an filename template list. The output +# is either a matching list of tables or a directory. The number of +# input tables may be either one or match the number of output tables. +# This is based on the t_imcopy procedure. +# +# Phil Hodge, 21-Aug-1987 Task created. +# Phil Hodge, 7-Sep-1988 Change parameter names for tables. +# Phil Hodge, 28-Dec-1989 Use iferr with call to tbtcpy. +# Phil Hodge, 26-Mar-1992 Remove calls to tbtext. +# Phil Hodge, 1-Jul-1995 Modify for FITS tables. +# Phil Hodge, 19-Jul-1995 Replace fnt calls with tbn. +# B.Simon 9-May-1997 Add code similar to trename +# Phil Hodge, 8-Apr-1999 In one_copy, call tbfpri. +# Phil hodge, 16-Apr-1999 Remove ttype from calling sequence of tbparse; +# use tbttyp to get table type; ext_type is not called. +# Phil Hodge, 7-Jun-1999 If input or output is redirected, set to STDIN +# or STDOUT without getting the cl parameter. +# Phil Hodge, 29-Jun-1999 In one_copy, don't call tbtacc if oldfile is STDIN. +# Phil Hodge, 2-Jan-2001 Check $nargs to see whether input & output were +# specified, rather than relying exclusively on F_REDIR. +# Phil Hodge, 28-Feb-2002 Add a call to sfree at the end of tcopy. + +procedure tcopy() + +pointer tablist1 # input table list +pointer tablist2 # output table list +bool verbose # print file names? +#-- +pointer sp +pointer table1 # input table name +pointer fname1 # input file name (i.e. without brackets) +pointer cdfname # input CDF name or EXTNAME +pointer table2 # output table name +pointer dir1 # input directory name +pointer dir2 # output directory name + +pointer list1, list2, tp +int root_len # number of char in input directory name +int numout # number of names in output list +bool fitsout # is the output just one FITS file? + +char src[SZ_FNAME], extn[SZ_FNAME] + +int nargs # number of command-line arguments +bool in_redir, out_redir # is input or output redirected? + +pointer tbnopen(), tbtopn() +int tbnget(), tbnlen() +int fstati() +int fnldir(), isdirectory(), strncmp() +int junk, hdu, tbparse(), exists, tbttyp() +int clgeti() +bool clgetb(), streq() + +begin + call smark (sp) + call salloc (tablist1, SZ_LINE, TY_CHAR) + call salloc (tablist2, SZ_LINE, TY_CHAR) + call salloc (table1, SZ_LINE, TY_CHAR) + call salloc (fname1, SZ_LINE, TY_CHAR) + call salloc (cdfname, SZ_LINE, TY_CHAR) + call salloc (table2, SZ_LINE, TY_CHAR) + call salloc (dir1, SZ_LINE, TY_CHAR) + call salloc (dir2, SZ_LINE, TY_CHAR) + + # Get input and output table template lists. What we do with the + # command-line arguments depends on how many there are and what + # (input, output, or both) has been redirected. + + nargs = clgeti ("$nargs") + in_redir = fstati (STDIN, F_REDIR) == YES + out_redir = fstati (STDOUT, F_REDIR) == YES + + if (in_redir || out_redir) { + + if (nargs >= 2) { + + if (in_redir) { + call strcpy ("STDIN", Memc[tablist1], SZ_LINE) + call clpstr ("intable", "STDIN") # update par file + } else { + call clgstr ("intable", Memc[tablist1], SZ_LINE) + } + call clgstr ("outtable", Memc[tablist2], SZ_LINE) + + } else if (nargs == 1) { + + if (in_redir) { # output may also have been redirected + # The cl thinks the argument is intable, but it's actually + # outtable, so assign the value to tablist2. + call strcpy ("STDIN", Memc[tablist1], SZ_LINE) + call clgstr ("intable", Memc[tablist2], SZ_LINE) + # update par file + call clpstr ("intable", "STDIN") + call clpstr ("outtable", Memc[tablist2]) + } else { # only output was redirected + call clgstr ("intable", Memc[tablist1], SZ_LINE) + call strcpy ("STDOUT", Memc[tablist2], SZ_LINE) + } + + } else if (nargs == 0) { + + if (in_redir) + call strcpy ("STDIN", Memc[tablist1], SZ_LINE) + else + call clgstr ("intable", Memc[tablist1], SZ_LINE) + + if (out_redir) + call strcpy ("STDOUT", Memc[tablist2], SZ_LINE) + else + call clgstr ("outtable", Memc[tablist2], SZ_LINE) + } + + } else { + + call clgstr ("intable", Memc[tablist1], SZ_LINE) + call clgstr ("outtable", Memc[tablist2], SZ_LINE) + } + + verbose = clgetb ("verbose") + + # Check if the output string is a directory. + + if (isdirectory (Memc[tablist2], Memc[dir2], SZ_LINE) > 0 && + !streq (Memc[tablist2], "STDOUT")) { + + list1 = tbnopen (Memc[tablist1]) + + while (tbnget (list1, Memc[table1], SZ_LINE) != EOF) { + + # Memc[fname1] is the name without any brackets. We need to + # remove brackets because they confuse fnldir, which we use + # to get the length of any directory prefix. + + junk = tbparse (Memc[table1], Memc[fname1], Memc[cdfname], + SZ_LINE, hdu) + root_len = fnldir (Memc[fname1], Memc[dir1], SZ_LINE) + + # Copy the output directory name to table2, and concatenate + # the input file name (without directory prefix and without + # the bracket suffix). + + call strcpy (Memc[dir2], Memc[table2], SZ_LINE) + call strcat (Memc[fname1+root_len], Memc[table2], SZ_LINE) + + call one_copy (Memc[table1], Memc[table2], verbose) + } + + call tbnclose (list1) + + } else { + + # Dummy open of the old file in case it's a URL. + if (strncmp (Memc[tablist1], "http://", 7) == 0) { + tp = tbtopn (Memc[tablist1], READ_ONLY, NULL) + call tbtclo (tp) + } + + # Expand the input and output table lists. + list1 = tbnopen (Memc[tablist1]) + list2 = tbnopen (Memc[tablist2]) + + numout = tbnlen (list2) + fitsout = false # initial value + if (numout == 1) { + # See if the output is a FITS file. It's OK to have many + # input tables with just one output FITS file. + junk = tbnget (list2, Memc[table2], SZ_LINE) + call tbnrew (list2) + if (tbttyp (Memc[table2], exists) == TBL_TYPE_FITS) + fitsout = true + } + + if (tbnlen (list1) != numout) { + if (!fitsout) { + call tbnclose (list1) + call tbnclose (list2) + call error (1, + "Number of input and output tables are not the same.") + } + } + + # Copy each table. + while (tbnget (list1, Memc[table1], SZ_LINE) != EOF) { + if (!fitsout) + junk = tbnget (list2, Memc[table2], SZ_LINE) + + call one_copy (Memc[table1], Memc[table2], verbose) + } + + call tbnclose (list1) + call tbnclose (list2) + } + + call sfree (sp) +end + +# ONE_COPY -- Copy a single table + +procedure one_copy (oldfile, newfile, verbose) + +char oldfile[ARB] # i: current file name +char newfile[ARB] # i: new file name +bool verbose # i: print informational message +#-- +bool done +int phu_copied # set by tbfpri and ignored +pointer sp, oldname, newname, tp + +bool use_fcopy # true if we should copy the file with fcopy + +pointer tbtopn() +bool streq(), is_wholetab() +int tbtacc(), exists, tbttyp() # exists is ignored +errchk tbfpri, tbtcpy, tbtopn + +begin + call smark (sp) + call salloc (oldname, SZ_FNAME, TY_CHAR) + call salloc (newname, SZ_FNAME, TY_CHAR) + + # Check to make sure the copy is legal + + done = false + use_fcopy = false + if (streq (oldfile, newfile)) { + call eprintf ("Cannot copy table to itself: %s\n") + call pargstr (oldfile) + + if (streq (oldfile, "STDIN")) { + use_fcopy = true + + } else if (tbtacc (oldfile) == YES) { + use_fcopy = true + + } else { + call eprintf ("Can only copy tables with tcopy: `%s'\n") + call pargstr (oldfile) + } + + if (use_fcopy) { + call tbtext (oldfile, Memc[oldname], SZ_FNAME) + call tbtext (newfile, Memc[newname], SZ_FNAME) + + iferr (call fcopy (Memc[oldname], Memc[newname])) { + call erract (EA_WARN) + } else { + done = true + } + } + + } else { + # Table extensions are copied by the table + # library function tbtcpy + + iferr { + call tbfpri (oldfile, newfile, phu_copied) + call tbtcpy (oldfile, newfile) + } then { + call erract (EA_WARN) + } else { + done = true + } + } + + # Print verbose message + + if (done && verbose) { + call printf ("# %s -> %s\n") + call pargstr (oldfile) + call pargstr (newfile) + call flush (STDOUT) + } + + call sfree (sp) + return +end diff --git a/pkg/utilities/nttools/tcopy/tdelete.x b/pkg/utilities/nttools/tcopy/tdelete.x new file mode 100644 index 00000000..87258d06 --- /dev/null +++ b/pkg/utilities/nttools/tcopy/tdelete.x @@ -0,0 +1,126 @@ +include + +# tdelete -- Delete a list of tables. If table cannot be deleted, warn the +# user but do not abort. Verify before deleting each table if user wishes. +# This is based on the t_imdelete procedure. +# +# Phil Hodge, 24-Aug-1987 Task created. +# Phil Hodge, 7-Sep-1988 Change parameter name for table. +# Phil Hodge, 16-Mar-1992 Include check to prevent deleting text files. +# Phil Hodge, 26-Mar-1992 Remove call to tbtext. +# Phil Hodge, 19-Jul-1995 Replace fnt calls with tbn. +# B.Simon 5-May-1995 Call delete if deleting an entire table +procedure tdelete() + +pointer list +bool verify +pointer sp, tablename, tablist + +pointer tbnopen() +int tbnget() +bool clgetb() + +begin + call smark (sp) + call salloc (tablename, SZ_PATHNAME, TY_CHAR) + call salloc (tablist, SZ_LINE, TY_CHAR) + + call clgstr ("table", Memc[tablist], SZ_LINE) + list = tbnopen (Memc[tablist]) + verify = clgetb ("verify") + + while (tbnget (list, Memc[tablename], SZ_PATHNAME) != EOF) + call one_delete (Memc[tablename], verify) + + # Reset the go_ahead parameter, overriding learn mode, in case tdelete + # is subsequently called from the background. + + if (verify) + call clputb ("go_ahead", true) + + call tbnclose (list) + call sfree (sp) +end + +# ONE_DELETE -- Delete a single table + +procedure one_delete (file, verify) + +char file[ARB] # i: current file name +bool verify # i: ask user for confirmation +#-- +bool doit +pointer sp, fname + +bool clgetb(), is_wholetab() +int access(), tbtacc(), strncmp() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Check to make sure the deletion is OK + + if (strncmp ("http:", file, 5) == 0) { + call eprintf ("Cannot delete URL `%s'\n") + call pargstr (file) + call sfree (sp) + return + } + + if (verify) { + if (tbtacc (file) == NO) { + # If table does not exist, warn user + # (since verify mode is in effect). + doit = false + call eprintf ("Cannot delete nonexistent table `%s'\n") + call pargstr (file) + } + + # Set default action of verify prompt (override learning of + # most recent response). + + call clputb ("go_ahead", clgetb ("default_action")) + call printf ("delete table `%s'") + call pargstr (file) + + doit = clgetb ("go_ahead") + + } else { + if (access (file, 0, TEXT_FILE) == YES) { + # We don't want users to be able to delete text files + # with tdelete if verify = false. + + doit = false + call eprintf ("Cannot delete text file with tdelete: `%s'\n") + call pargstr (file) + + } else { + doit = true + } + } + + # Do the deletion + + if (doit) { + if (is_wholetab (file)) { + # Entire files are deleted with the fio delete + + call tbtext (file, Memc[fname], SZ_FNAME) + iferr (call delete (Memc[fname])) { + call erract (EA_WARN) + } + + } else { + # Table extensions are deleted by the table + # library function tbtdel + + iferr (call tbtdel (file)) { + call erract (EA_WARN) + } + } + } + + call sfree (sp) + return +end diff --git a/pkg/utilities/nttools/tcopy/trename.x b/pkg/utilities/nttools/tcopy/trename.x new file mode 100644 index 00000000..c4273b0b --- /dev/null +++ b/pkg/utilities/nttools/tcopy/trename.x @@ -0,0 +1,185 @@ +include + +# trename -- Rename table(s) + +# The input tables are given by an filename template list. The output +# is either a matching list of tables or a directory. The number of +# input tables may be either one or match the number of output tables. +# This is based on the t_imcopy procedure. +# +# Phil Hodge, 21-Aug-1987 Task created. +# Phil Hodge, 7-Sep-1988 Change parameter names for tables. +# Phil Hodge, 28-Dec-1989 Use iferr with call to tbtren. +# Phil Hodge, 16-Mar-1992 Include check to prevent renaming text files. +# Phil Hodge, 1-Jul-1995 Modify for FITS tables. +# Phil Hodge, 19-Jul-1995 Replace fnt calls with tbn. +# B.Simon 5-May-1997 Call rename if renaming entire table +# B.Simon 9-May-1997 Add table type check + +procedure trename() + +pointer tablist1 # input table list +pointer tablist2 # output table list +bool verbose # print operations? +#-- +pointer sp +pointer table1 # input table name +pointer fname1 # input file name (i.e. without brackets) +pointer cdfname # input CDF name or EXTNAME +pointer table2 # output table name +pointer dir1 # input directory name +pointer dir2 # output directory name + +pointer list1, list2 +int root_len # number of char in input directory name + +pointer tbnopen() +int tbnget(), tbnlen() +int fnldir(), isdirectory() +int junk, ttype, hdu, tbparse() +bool clgetb(), streq() + +begin + call smark (sp) + call salloc (tablist1, SZ_LINE, TY_CHAR) + call salloc (tablist2, SZ_LINE, TY_CHAR) + call salloc (table1, SZ_LINE, TY_CHAR) + call salloc (fname1, SZ_LINE, TY_CHAR) + call salloc (cdfname, SZ_LINE, TY_CHAR) + call salloc (table2, SZ_LINE, TY_CHAR) + call salloc (dir1, SZ_LINE, TY_CHAR) + call salloc (dir2, SZ_LINE, TY_CHAR) + + # Get input and output table template lists. + call clgstr ("intable", Memc[tablist1], SZ_LINE) + call clgstr ("outtable", Memc[tablist2], SZ_LINE) + + verbose = clgetb ("verbose") + + # Check if the output string is a directory. + + if (isdirectory (Memc[tablist2], Memc[dir2], SZ_LINE) > 0 && + !streq (Memc[tablist2], "STDOUT")) { + + list1 = tbnopen (Memc[tablist1]) + + while (tbnget (list1, Memc[table1], SZ_LINE) != EOF) { + + # Memc[fname1] is the name without any brackets. We need to + # remove brackets because they confuse fnldir, which we use + # to get the length of any directory prefix. + + junk = tbparse (Memc[table1], Memc[fname1], Memc[cdfname], + SZ_LINE, ttype, hdu) + root_len = fnldir (Memc[fname1], Memc[dir1], SZ_LINE) + + # Copy the output directory name to table2, and concatenate + # the input file name (without directory prefix and without + # the bracket suffix). + + call strcpy (Memc[dir2], Memc[table2], SZ_LINE) + call strcat (Memc[fname1+root_len], Memc[table2], SZ_LINE) + + call one_rename (Memc[table1], Memc[table2], verbose) + } + + call tbnclose (list1) + + } else { + + # Expand the input and output table lists. + list1 = tbnopen (Memc[tablist1]) + list2 = tbnopen (Memc[tablist2]) + + if (tbnlen (list1) != tbnlen (list2)) { + call tbnclose (list1) + call tbnclose (list2) + call error (1, "Number of input and output tables not the same") + } + + # Rename each table. + + while ((tbnget (list1, Memc[table1], SZ_LINE) != EOF) && + (tbnget (list2, Memc[table2], SZ_LINE) != EOF)) { + + call one_rename (Memc[table1], Memc[table2], verbose) + } + + call tbnclose (list1) + call tbnclose (list2) + } +end + +# ONE_RENAME -- Rename a single table + +procedure one_rename (oldfile, newfile, verbose) + +char oldfile[ARB] # i: current file name +char newfile[ARB] # i: new file name +bool verbose # i: print informational message +#-- +bool done +pointer sp, oldname, newname + +bool streq(), is_wholetab() +int access(), tbtacc(), ext_type() + +begin + call smark (sp) + call salloc (oldname, SZ_FNAME, TY_CHAR) + call salloc (newname, SZ_FNAME, TY_CHAR) + + # Check to make sure the copy is legal + + done = false + if (streq (oldfile, newfile)) { + call eprintf ("Cannot rename table to itself: %s\n") + call pargstr (oldfile) + + } else if (access (oldfile, 0, TEXT_FILE) == YES) { + call eprintf ("Cannot rename text file with trename: `%s'\n") + call pargstr (oldfile) + + } else if (is_wholetab (oldfile) && is_wholetab (newfile) && + ext_type (oldfile) == ext_type (newfile)) { + + # Entire files of the same type are renamed with the fio rename + + if (tbtacc (oldfile) == NO) { + call eprintf ("Can only rename tables with trename: `%s'\n") + call pargstr (oldfile) + + } else { + call tbtext (oldfile, Memc[oldname], SZ_FNAME) + call tbtext (newfile, Memc[newname], SZ_FNAME) + + iferr (call rename (Memc[oldname], Memc[newname])) { + call erract (EA_WARN) + } else { + done = true + } + } + + } else { + # Table extensions are renamed by the table + # library function tbtren + + iferr (call tbtren (oldfile, newfile)) { + call erract (EA_WARN) + } else { + done = true + } + } + + # Print verbose message + + if (done && verbose) { + call printf ("%s -> %s\n") + call pargstr (oldfile) + call pargstr (newfile) + call flush (STDOUT) + } + + call sfree (sp) + return +end diff --git a/pkg/utilities/nttools/tcreate.par b/pkg/utilities/nttools/tcreate.par new file mode 100644 index 00000000..4a95daf8 --- /dev/null +++ b/pkg/utilities/nttools/tcreate.par @@ -0,0 +1,12 @@ +table,s,a,"",,,"name of table to be created" +cdfile,s,a,"STDIN",,,"name of file containing column descriptions" +datafile,s,a,"STDIN",,,"name of file containing data" +uparfile,s,h,"",,,"name of file containing header parameters" +nskip,i,h,0,0,,"number of header lines to skip in data file" +nlines,i,h,0,0,,"number of lines in data file per row in table" +nrows,i,h,0,0,,"number of rows [zero for all]" +hist,b,h,yes,,,"add a history record with creation date?" +extrapar,i,h,5,0,,"extra space for header parameters" +tbltype,s,h,"default","default|row|column|text",,"type of table" +extracol,i,h,0,0,,"number of extra columns to allocate" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/tcreate/gnextl.x b/pkg/utilities/nttools/tcreate/gnextl.x new file mode 100644 index 00000000..42da95e4 --- /dev/null +++ b/pkg/utilities/nttools/tcreate/gnextl.x @@ -0,0 +1,152 @@ +include +include + +# g_next_l -- get next line from text file +# This routine calls getlline (get long line) to get a line from a text file. +# A flag is set to true if the line is a comment rather than a data line. +# The returned line will be terminated by EOS rather than by '\n'. +# If the line is a comment, the line will be skipped. In-line comments +# are stripped off. A '#' which is enclosed in quotes (single or double) +# or preceded by '\' will not be +# counted as a comment character. A newline terminates the string regardless +# of what precedes or follows it; a newline within a string is an error, +# though. The function value is the number of characters preceding the EOS, +# or EOF is returned when the end of file is reached. +# The linenum I/O parameter is incremented each time a line is read, +# regardless of whether the line is data, a comment, or blank. +# +# The buffer is scanned to be sure it contains a '\n'. If not, we haven't +# read the entire line (i.e. it's longer than maxch); we regard that as +# a serious error. +# +# Phil Hodge, 22-May-1992 Function created based on tbzlin. +# Phil Hodge, 10-May-1993 Include line number in error messages. + +int procedure g_next_l (fd, buf, maxch, linenum) + +int fd # i: fd for the file +char buf[ARB] # o: buffer to receive the line that was read +int maxch # i: size of line buffer +int linenum # io: line number counter +#-- +pointer sp +pointer errmes # scratch for error message +char ch # a character from the string which was read +int ip # counter for a character in the string +int nchar # number of char read by getlline +bool done # flag for terminating loop +bool comment # is current line commented out? +bool at_end # true when we reach the end of the line ('\n') +bool odd_squotes # true if current character is within quoted string +bool odd_dquotes # true if current char is within double quoted string +int getlline() + +begin + done = false + # This loop is terminated by EOF or by reading a line that + # is not a comment or blank. + while ( !done ) { + + nchar = getlline (fd, buf, maxch) + if (nchar == EOF) + return (EOF) # end of file reached + + linenum = linenum + 1 # increment line number counter + + # If there's no newline, we haven't read the entire line. + at_end = false + do ip = 1, maxch { + if (buf[ip] == EOS) { + break + } else if (buf[ip] == '\n') { + at_end = true # we've read entire line + break + } + } + if (!at_end) { + call smark (sp) + call salloc (errmes, SZ_LINE, TY_CHAR) + call sprintf (Memc[errmes], SZ_LINE, + "Input line %d is too long.") + call pargi (linenum) + call error (1, Memc[errmes]) + } + + ip = 1 + while (IS_WHITE(buf[ip]) && ip < maxch) + ip = ip + 1 + + # Blank up through maxch? Treat it as a comment. + if (ip >= maxch) { + comment = true + + } else if (buf[ip] == NEWLINE || buf[ip] == '#' || buf[ip] == EOS) { + comment = true + + } else { + comment = false + + # The current line is not a comment or blank; + # replace '\n' or '#' by EOS. First check whether the + # first non-blank character begins a quoted string. + if (buf[ip] == SQUOTE) + odd_squotes = true + else + odd_squotes = false + if (buf[ip] == DQUOTE) + odd_dquotes = true + else + odd_dquotes = false + + ip = ip + 1 + at_end = false + while ( !at_end ) { + ch = buf[ip] + # Check for end of buffer or newline or in-line comment. + if (ch == NEWLINE) { + buf[ip] = EOS + at_end = true + } else if (ch == SQUOTE) { + # Toggle flag for in/out of quoted string. + odd_squotes = !odd_squotes + ip = ip + 1 + } else if (ch == DQUOTE) { + odd_dquotes = !odd_dquotes + ip = ip + 1 + } else if (ch == '#') { + # '#' is not a comment if it's in a quoted string + if (odd_squotes || odd_dquotes) { + ip = ip + 1 + # ... or if it's escaped. + } else if (buf[ip-1] == ESCAPE) { + ip = ip + 1 + } else { # it's an in-line comment + buf[ip] = EOS + at_end = true + } + } else if (ch == EOS) { + at_end = true # (can't get here) + } else if (ip >= maxch) { # end of buffer reached + at_end = true # (can't get here) + buf[maxch+1] = EOS + } else { + ip = ip + 1 + } + } + if (odd_squotes || odd_dquotes) { + call smark (sp) + call salloc (errmes, SZ_LINE, TY_CHAR) + call sprintf (Memc[errmes], SZ_LINE, + "Unbalanced quotes in line %d.") + call pargi (linenum) + call error (1, Memc[errmes]) + } + nchar = ip - 1 + } + + # If the line is a comment (or blank), read another line. + if (!comment) + done = true + } + return (nchar) +end diff --git a/pkg/utilities/nttools/tcreate/mkpkg b/pkg/utilities/nttools/tcreate/mkpkg new file mode 100644 index 00000000..5a14c82c --- /dev/null +++ b/pkg/utilities/nttools/tcreate/mkpkg @@ -0,0 +1,12 @@ +# Update the tcreate application code in the ttools package library +# Author: HODGE, 2-FEB-1988 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + tcreate.x + gnextl.x + ; diff --git a/pkg/utilities/nttools/tcreate/tcreate.x b/pkg/utilities/nttools/tcreate/tcreate.x new file mode 100644 index 00000000..6febb642 --- /dev/null +++ b/pkg/utilities/nttools/tcreate/tcreate.x @@ -0,0 +1,958 @@ +include # for EA_ERROR +include # this defines SZ_TIME +include # defines F_REDIR +include # defines IS_WHITE +include + +define SZ_LONG_LINE (8192+SZ_LINE) # allows input line up to 8192 char +define SZ_FMT 17 # size of string containing print format +define SZ_DTYPE 29 # size of string for data type +define CPSPACE 21 # size of increment in space for col descr ptrs +define T_MAXDIM 7 # maximum dimension for an array in a table + +# These three macros are for dim, the pointer to an array of pointers to +# dimension info. +# for column i: +# dimension is TCR_NDIM (dim, i) +# length of axis j is TCR_AXLEN (dim, i, j) +define LEN_DIM_INFO T_MAXDIM + 1 # unit = SZ_INT32 +define TCR_NDIM Memi[Memi[$1+$2-1]] # dimension of array +define TCR_AXLEN Memi[Memi[$1+$2-1]+$3] # length of an axis + +# tcreate -- Program to create a table from data in an ASCII file. +# +# Phil Hodge, 22-Jul-1987 Task created +# Phil Hodge, 11-Aug-1987 Modify mk_new_cols for datatype=-n for char string. +# Phil Hodge, 8-Sep-1987 Change name from tcreat. +# Phil Hodge, 15-Oct-1987 Use tbcigi instead of COL_DTYPE. +# Phil Hodge, 20-Sep-1988 Print warning if file does not exist. +# Phil Hodge, 9-Mar-1989 Change data type in call to tbhanp from char to int. +# Phil Hodge, 17-May-1989 Add history record to table giving creation date. +# Phil Hodge, 22-May-1992 Allow input lines up to 1024 char; print warning +# if entire line of data file is not read; +# print prompt if input is STDIN and not redirected. +# Phil Hodge, 11-Jan-1993 In mk_new_cols, move "ncols = ncols + 1" to just +# before the call to tbcdef. +# Phil Hodge, 10-May-1993 In row_copy, include TY_SHORT. +# Phil Hodge, 11-Aug-1993 Add tcr_ctoi, which calls ctoi after skipping over +# leading whitespace and/or a "+" sign; call in row_copy. +# Phil Hodge, 18-Nov-1994 Add option of creating columns of arrays. +# Phil Hodge, 19-Jul-1995 Add tp to calling sequence of tbcisa. +# Phil Hodge, 20-Jul-1998 In cp_upar_tbl, call tbfres for a FITS table. +# Phil Hodge, 18-Jun-1999 Add option to create a text table with explicit +# column definitions. +# Phil Hodge, 29-Jul-1999 In tcr_ctoi, check that the value in the data file +# has no fractional part. linenum was added to the calling +# sequence of tcr_ctoi for a possible error message. +# Phil Hodge, 12-Nov-2001 Allow input lines up to 8192 characters in length. +# Phil Hodge, 24-Dec-2003 Move the call to tbcisa from mk_new_cols to a +# point after the call to tbtcre. This had to be done because +# tbcisa sets the value of a header keyword, and the table file +# doesn't exist until after tbtcre has been called. Add the +# three routines dim_alloc, dim_set, and dim_free. Also change +# the data type of cptr from TY_INT to TY_POINTER. +# Phil Hodge, 20-Dec-2004 Check cdname, dname, pname for " ". + +procedure tcreate() + +pointer sp +pointer tname # scratch for name of table to be created +pointer cdname # scratch for name of file of column definitions +pointer dname # scratch for name of file for table data +pointer pname # scratch for name of file of header parameters +pointer ttype # scratch for table type (e.g. "row") +pointer tp # pointer to descriptor for output table +pointer cptr # pointer to array of column pointers +pointer dim # pointer to array of column dimension info +int uparfd # fd for input file of header parameters +int nskip # number of lines to skip at beg of data file +int nlines # number of lines in file per row in table +int npar # number of header parameters +int nrows, ncols # number of rows and columns in table +int extracol # number of extra columns to allocate +int extrapar # extra space to allocate for header parameters +int maxcols # size of arrays for column info +bool histflag # add a history record with creation date? +pointer tbtopn() +int clgeti() +bool clgetb() +bool isblank() + +begin + call smark (sp) + call salloc (tname, SZ_FNAME, TY_CHAR) + call salloc (cdname, SZ_FNAME, TY_CHAR) + call salloc (dname, SZ_FNAME, TY_CHAR) + call salloc (pname, SZ_FNAME, TY_CHAR) + call salloc (ttype, SZ_FNAME, TY_CHAR) + + call clgstr ("table", Memc[tname], SZ_FNAME) + call clgstr ("cdfile", Memc[cdname], SZ_FNAME) + call clgstr ("datafile", Memc[dname], SZ_FNAME) + call clgstr ("uparfile", Memc[pname], SZ_FNAME) + nskip = clgeti ("nskip") + nlines = clgeti ("nlines") + nrows = clgeti ("nrows") + histflag = clgetb ("hist") + extrapar = clgeti ("extrapar") + call clgstr ("tbltype", Memc[ttype], SZ_FNAME) + + # The user might have given the name as " " instead of EOS (""); check + # for this, and in this case make sure the value is EOS to simplify + # checking elsewhere in this file. + if (isblank (Memc[cdname])) + Memc[cdname] = EOS + if (isblank (Memc[dname])) + Memc[dname] = EOS + if (isblank (Memc[pname])) + Memc[pname] = EOS + + tp = tbtopn (Memc[tname], NEW_FILE, 0) + + if (Memc[ttype] == 'r') { # row-ordered stsdas format + call tbpset (tp, TBL_WHTYPE, TBL_TYPE_S_ROW) + extracol = clgeti ("extracol") + } else if (Memc[ttype] == 'c') { # column-ordered stsdas format + if (nrows <= 0) + call error (1, "must specify nrows>0 for column-ordered table") + call tbpset (tp, TBL_WHTYPE, TBL_TYPE_S_COL) + call tbpset (tp, TBL_ALLROWS, nrows) + extracol = 0 + } else if (Memc[ttype] == 't') { # text table + # not a simple text table, one with explicit column definitions + call tbpset (tp, TBL_WHTYPE, TBL_TYPE_TEXT) + call tbpset (tp, TBL_SUBTYPE, TBL_SUBTYPE_EXPLICIT) + } else { # default type + extracol = clgeti ("extracol") + } + + # Read column descriptions, and create columns; ncols = 0 is OK. + call mk_new_cols (Memc[cdname], tp, cptr, dim, ncols, maxcols) + + # Increase allocation of space for columns. + if (extracol > 0) + call tbpset (tp, TBL_INCR_ROWLEN, extracol) + + # Open the (optional) file containing header parameters, and count how + # many there are. If npar = 0 the input file will not be left open. + if (Memc[pname] != EOS) { + call c_user_par (Memc[pname], uparfd, npar) + } else { + npar = 0 # there is no upar file + uparfd = NULL + } + if (histflag) + npar = npar + 1 + + # Specify how much space to allocate for header parameters. + call tbpset (tp, TBL_MAXPAR, npar+extrapar) + + # Open (create) the table. + call tbtcre (tp) + + # Assign column dimension info, if appropriate. + call dim_set (tp, Memi[cptr], dim, ncols) + + # Copy header parameters to table, and close the uparfile. + call cp_upar_tbl (tp, uparfd, histflag) + + # Read from data file and write to table. + if (ncols > 0) + call cp_dat_tbl (Memc[dname], tp, Memi[cptr], nskip, nlines, nrows) + + call tbtclo (tp) + if (cptr != NULL) + call mfree (cptr, TY_POINTER) + call dim_free (dim, maxcols) + + call sfree (sp) +end + + +# mk_new_cols -- make new columns +# This routine reads column descriptions from an input ASCII file +# and defines those columns in the table. + +procedure mk_new_cols (cdname, tp, cptr, dim, ncols, maxcols) + +char cdname[ARB] # i: name of column-definitions file +pointer tp # i: pointer to table descriptor +pointer cptr # o: pointer to array of column descriptors +pointer dim # o: pointer to array of column dimension info +int ncols # o: number of columns created (may be zero) +int maxcols # o: size of arrays for column info +#-- +pointer sp +pointer lbuf # buffer for reading lines from col descr file +char colname[SZ_COLNAME] # column name +char colunits[SZ_COLUNITS] # column units +char colfmt[SZ_COLFMT] # print format for column +char chdtype[SZ_DTYPE] # column data type expressed as a char string +int fd # for input ASCII file +int linenum # line number counter (ignored) +int datatype # column data type expressed as an int +int nelem # array length +int ip # index in line of text from input file +int access(), open(), g_next_l(), ctowrd(), fstati() +bool streq() + +begin + ncols = 0 # initial values + cptr = NULL + dim = NULL + + if (cdname[1] == EOS) { + call eprintf ("No cdfile; an empty table will be created.\n") + return + } else if (access (cdname, 0, 0) == NO) { + call eprintf ("WARNING: can't read file %s;\n") + call pargstr (cdname) + call eprintf (" ... an empty table will be created.\n") + return + } else if (streq (cdname, "STDIN")) { + # Print a prompt if the input is not redirected. + if (fstati (STDIN, F_REDIR) == NO) { + call printf ( + "Give column definitions (name, datatype, print format, units)\n") + call printf (" ... then newline & EOF to finish.\n") + call flush (STDOUT) + } + } + + fd = open (cdname, READ_ONLY, TEXT_FILE) + + call smark (sp) + call salloc (lbuf, SZ_LONG_LINE, TY_CHAR) + + maxcols = CPSPACE + call calloc (cptr, maxcols, TY_POINTER) + call dim_alloc (dim, ncols, maxcols) + + # While get next non-comment line ... + linenum = 0 + while (g_next_l (fd, Memc[lbuf], SZ_LONG_LINE, linenum) != EOF) { + ip = 1 + if (ctowrd (Memc[lbuf], ip, colname, SZ_COLNAME) < 1) + call error (1, "could not read column name") + if (ncols+1 > maxcols) { + maxcols = maxcols + CPSPACE + call realloc (cptr, maxcols, TY_POINTER) + call dim_alloc (dim, ncols, maxcols) + } + if (ctowrd (Memc[lbuf], ip, chdtype, SZ_DTYPE) < 1) { + call strcpy ("r", chdtype, SZ_DTYPE) # default is real + colfmt[1] = EOS + colunits[1] = EOS + } else if (ctowrd (Memc[lbuf], ip, colfmt, SZ_COLFMT) < 1) { + colfmt[1] = EOS + colunits[1] = EOS + } else if (ctowrd (Memc[lbuf], ip, colunits, SZ_COLUNITS) < 1) { + colunits[1] = EOS + } + + # Convert the format from Fortran style to SPP style. + call tbbftp (colfmt, colfmt) + + iferr { + # Convert data type to an integer. Use ncols+1 because + # ncols hasn't been incremented yet. + call tcr_nelem (chdtype, + TCR_NDIM (dim, ncols+1), TCR_AXLEN (dim, ncols+1, 1), + T_MAXDIM, nelem, datatype) + } then { + call erract (EA_WARN) + call eprintf ("column `%s' ignored\n") + call pargstr (colname) + } else { + # Create the column. + ncols = ncols + 1 # bug fix 1/11/93 + call tbcdef (tp, Memi[cptr+ncols-1], + colname, colunits, colfmt, datatype, nelem, 1) + } + } + call close (fd) # done with column descriptions file + call sfree (sp) +end + +# Allocate or reallocate memory for the array of column dimensions. + +procedure dim_alloc (dim, ncols, maxcols) + +pointer dim # io: allocate (or reallocate) this buffer +int ncols # i: current number of columns +int maxcols # i: new number of elements for dim +#-- +int i, k # loop indices + +begin + if (dim == NULL) + call malloc (dim, maxcols, TY_POINTER) + else + call realloc (dim, maxcols, TY_POINTER) + + # Assign initial values. These may be updated later. + do i = ncols+1, maxcols { # zero indexed + call malloc (Memi[dim+i-1], LEN_DIM_INFO, TY_INT) + TCR_NDIM (dim, i) = 1 + do k = 1, T_MAXDIM + TCR_AXLEN (dim, i, k) = 1 + } +end + +# For each column of multi-dimensional arrays, call the routine to assign +# the keyword giving the length of each axis. + +procedure dim_set (tp, cp, dim, ncols) + +pointer tp # i: pointer to table descriptor +pointer cp[ARB] # i: array of column descriptors +pointer dim # i: pointer to array of column dimension info +int ncols # i: current number of columns +#-- +int i # loop index + +begin + do i = 1, ncols { + if (TCR_NDIM (dim, i) > 1) + call tbcisa (tp, cp[i], TCR_NDIM(dim,i), TCR_AXLEN(dim,i,1)) + } +end + +# Free memory for the array of column dimensions. + +procedure dim_free (dim, maxcols) + +pointer dim # io: pointer to array of column dimension info +int maxcols # i: new number of elements for dim +#-- +int i # loop index + +begin + if (dim == NULL) + return + + do i = 1, maxcols { # zero indexed + if (Memi[dim+i-1] != NULL) + call mfree (Memi[dim+i-1], TY_INT) + } + call mfree (dim, TY_POINTER) +end + +# c_user_par -- count header parameters +# This routine opens an input ASCII file containing header parameters +# and counts the number of such parameters. If the input file exists +# and does contain parameters, the file will be left open; otherwise, +# the input file will be closed, and both npar and uparfd will be set +# to zero. +# Blank and comment lines are ignored. + +procedure c_user_par (pname, uparfd, npar) + +char pname[ARB] # i: name of file of header parameters +int uparfd # o: fd for input file of header parameters +int npar # o: number of header parameters in file +#-- +pointer sp +pointer lbuf # scratch for input line buffer +int linenum # line number counter (ignored) +int access(), open(), g_next_l() + +begin + uparfd = NULL # initial values + npar = 0 + + if (pname[1] == EOS) { + return + } else if (access (pname, 0, 0) == NO) { + call eprintf ("WARNING: can't read file %s.\n") + call pargstr (pname) + return + } + uparfd = open (pname, READ_ONLY, TEXT_FILE) + + call smark (sp) + call salloc (lbuf, SZ_LONG_LINE, TY_CHAR) + + linenum = 0 + while (g_next_l (uparfd, Memc[lbuf], SZ_LONG_LINE, linenum) != EOF) + npar = npar + 1 + + call sfree (sp) + if (npar <= 0) { + call close (uparfd) + uparfd = NULL + } +end + + +# cp_upar_tbl -- copy header parameters to table +# This routine reads header parameters (keyword, type, value) from an +# ASCII file and writes them to the table. The input file is then closed. +# If uparfd is zero then it is assumed that the file does not exist. + +procedure cp_upar_tbl (tp, uparfd, histflag) + +pointer tp # i: pointer to table descriptor +int uparfd # io: fd for file of header parameters +bool histflag # i: add a history record with current date? +#-- +pointer sp +pointer lbuf # scratch for input line buffer +pointer datetime # scratch for date and time +pointer history # scratch for history record +char keyword[SZ_KEYWORD] # keyword for parameter +char chdtype[SZ_DTYPE] # column data type expressed as a char string +long old_time, new_time # zero; current clock time +int datatype # data type: TY_CHAR, etc +int linenum # line number counter (ignored) +int ip # counter for indexing in line buffer +int parnum # parameter number (ignored) +int tbltype # table type, to check for fits type +int g_next_l(), ctowrd() +int tbpsta(), tbfres() +long clktime() + +begin + call smark (sp) + call salloc (lbuf, SZ_LONG_LINE, TY_CHAR) + + tbltype = tbpsta (tp, TBL_WHTYPE) + + # If there is a file of header parameters, read them and add to the + # table header. + if (uparfd != NULL) { + + call seek (uparfd, BOF) # rewind to beginning of file + linenum = 0 + while (g_next_l (uparfd, Memc[lbuf], SZ_LONG_LINE, + linenum) != EOF) { + ip = 1 + # Read: keyword datatype value comment + if (ctowrd (Memc[lbuf], ip, keyword, SZ_KEYWORD) <= 0) { + call eprintf ("line is `%s'\n") + call pargstr (Memc[lbuf]) + call error (1, "bad line in 'uparfile'") + } + if (tbltype == TBL_TYPE_FITS && tbfres (keyword) == YES) + next # skip reserved keywords if FITS table + if (ctowrd (Memc[lbuf], ip, chdtype, SZ_DTYPE) <= 0) { + call eprintf ("line is `%s'\n") + call pargstr (Memc[lbuf]) + call error (1, "bad line in 'uparfile'") + } + call strlwr (chdtype) + datatype = chdtype[1] + switch (datatype) { + case 'r': + datatype = TY_REAL + case 'i': + datatype = TY_INT + case 'd': + datatype = TY_DOUBLE + case 'b': + datatype = TY_BOOL + default: + datatype = TY_CHAR + } + while (IS_WHITE(Memc[lbuf+ip-1])) + ip = ip + 1 + call tbhanp (tp, keyword, datatype, Memc[lbuf+ip-1], parnum) + } + # Close the input ASCII file containing header parameters. + call close (uparfd) + } + + if (histflag) { + + call salloc (datetime, SZ_TIME, TY_CHAR) + call salloc (history, SZ_LINE, TY_CHAR) + + old_time = 0 + new_time = clktime (old_time) + call cnvtime (new_time, Memc[datetime], SZ_TIME) + call strcpy ("Created ", Memc[history], SZ_LINE) + call strcat (Memc[datetime], Memc[history], SZ_LINE) + + call tbhadt (tp, "history", Memc[history]) + } + + call sfree (sp) +end + + +# cp_dat_tbl -- copy data to table +# This routine reads from an ASCII data file and writes the values to +# the table. A subroutine is called to do the actual copying for each row. + +procedure cp_dat_tbl (dname, tp, cptr, nskip, nlines, nrows) + +char dname[ARB] # i: name of file containing table data +pointer tp # i: pointer to table descriptor +pointer cptr[ARB] # i: array of pointers to column descriptors +int nskip # i: number of lines to skip at beginning +int nlines # i: number of lines per data file record +int nrows # i: upper limit on number of rows (if > 0) +#-- +pointer sp +pointer linebuf # scratch for skipping header lines +int fd # file descriptor for ASCII data file +int rownum # row number +int linenum # line number counter +int k # loop index +int stat +bool done +int access(), open(), getlline(), fstati() +bool streq() + +begin + if (dname[1] == EOS) { + return + } else if (access (dname, 0, 0) == NO) { + call eprintf ("WARNING: file `%s' does not exist;\n") + call pargstr (dname) + call eprintf (" ... an empty table will be created.\n") + return + } else if (streq (dname, "STDIN")) { + # Print a prompt if the input is not redirected. + if (fstati (STDIN, F_REDIR) == NO) { + call printf ( + "Give table data ... then newline & EOF to finish.\n") + call flush (STDOUT) + } + } + fd = open (dname, READ_ONLY, TEXT_FILE) + + # Skip "header" lines. + if (nskip > 0) { + call smark (sp) + call salloc (linebuf, SZ_LONG_LINE, TY_CHAR) + do k = 1, nskip + stat = getlline (fd, Memc[linebuf], SZ_LONG_LINE) + call sfree (sp) # done with scratch space + } + + # Read each record (which may be more than one line) from the + # data file, and write the values to the output row in the table. + rownum = 1 + linenum = nskip # number of lines read so far + done = false + while ( !done ) { + call row_copy (tp, fd, cptr, rownum, nlines, linenum, done) + rownum = rownum + 1 + if (nrows > 0 && rownum > nrows) + done = true + } + call close (fd) +end + + + +# row_copy -- copy to a row of the table +# This routine reads one or more records from data file and writes +# a single row to the table. + +procedure row_copy (tp, fd, cptr, rownum, nlines, linenum, done) + +pointer tp # i: pointer to table descriptor +pointer cptr[ARB] # i: array of pointers to column descriptors +int fd # i: file descriptor for input data file +int rownum # i: row number in table +int nlines # i: number of lines per data file record +int linenum # io: line number counter +bool done # io: set to true when finished +#-- +pointer sp +pointer lbuf # buffer for reading from data file +int ncols # number of columns in table +int col # loop index (column number) +int k # loop index for skipping lines +int dtype # data type of a column (-n for char) +int nelem # number of elements in array +int i # loop index for element number +int n # counter for number of lines per table row +int ip # index in line buffer lbuf +int nchar # number of char in text string +int stat +pointer str # buffer for value to be put in table +double dval # " +int ival # " +bool bval +int tbpsta(), tbcigi(), g_next_l(), tcr_ctoi(), ctod(), ctowrd() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (lbuf, SZ_LONG_LINE, TY_CHAR) + + ncols = tbpsta (tp, TBL_NCOLS) + + n = 1 + if (g_next_l (fd, Memc[lbuf], SZ_LONG_LINE, linenum) == EOF) { + done = true + return + } + ip = 1 + for (col=1; col<=ncols; col=col+1) { + dtype = tbcigi (cptr[col], TBL_COL_DATATYPE) + nelem = tbcigi (cptr[col], TBL_COL_LENDATA) + switch (dtype) { + case TY_REAL,TY_DOUBLE: + do i = 1, nelem { + if (ctod (Memc[lbuf], ip, dval) < 1) { + if (nlines > 0 && n >= nlines) + return # ignore any remaining columns + + # Print warning if we're not really at the end of line. + call tcr_check_eol (Memc[lbuf+ip-1], linenum) + + if (g_next_l (fd, Memc[lbuf], SZ_LONG_LINE, + linenum) == EOF) { + done = true + return + } + n = n + 1 + ip = 1 + if (ctod (Memc[lbuf], ip, dval) < 1) { + call sprintf (Memc[str], SZ_LINE, + "badly out of synch in line %d in data file\n") + call pargi (linenum) + call error (1, Memc[str]) + } + } + call tbaptd (tp, cptr[col], rownum, dval, i, 1) + } + + case TY_INT,TY_SHORT: + do i = 1, nelem { + if (tcr_ctoi (Memc[lbuf], ip, ival, linenum) < 1) { + if (nlines > 0 && n >= nlines) + return # ignore any remaining columns + + call tcr_check_eol (Memc[lbuf+ip-1], linenum) + + if (g_next_l (fd, Memc[lbuf], SZ_LONG_LINE, + linenum) == EOF) { + done = true + return + } + n = n + 1 + ip = 1 + if (tcr_ctoi (Memc[lbuf], ip, ival, linenum) < 1) { + call sprintf (Memc[str], SZ_LINE, + "badly out of synch in line %d in data file\n") + call pargi (linenum) + call error (1, Memc[str]) + } + } + call tbapti (tp, cptr[col], rownum, ival, i, 1) + } + + case TY_BOOL: + do i = 1, nelem { + if (ctowrd (Memc[lbuf], ip, Memc[str], SZ_LINE) < 1) { + if (nlines > 0 && n >= nlines) + return # ignore any remaining columns + + call tcr_check_eol (Memc[lbuf+ip-1], linenum) + + if (g_next_l (fd, Memc[lbuf], SZ_LONG_LINE, + linenum) == EOF) { + done = true + return + } + n = n + 1 + ip = 1 + if (ctowrd (Memc[lbuf], ip, Memc[str], SZ_LINE) < 1) { + call sprintf (Memc[str], SZ_LINE, + "badly out of synch in line %d in data file\n") + call pargi (linenum) + call error (1, Memc[str]) + } + } + call strlwr (Memc[str]) + if (Memc[str] == 'y' || Memc[str] == 't') # yes or true + bval = true + else if (Memc[str] == 'n' || Memc[str] == 'f') # no or false + bval = false + else { + call strcat (" is not a valid Boolean value", + Memc[str], SZ_LINE) + call error (1, Memc[str]) + } + call tbaptb (tp, cptr[col], rownum, bval, i, 1) + } + + default: + if (dtype >= 0) + call error (1, "invalid data type got past tbbtyp") + + do i = 1, nelem { + # Be careful to distinguish between a value of "" at the + # end of a line and actually reaching the end of the line; + # ctowrd returns 0 in both cases. First skip whitespace. + while (IS_WHITE(Memc[lbuf+ip-1])) + ip = ip + 1 + if (Memc[lbuf+ip-1] == '\n' || Memc[lbuf+ip-1] == EOS) { + if (nlines > 0 && n >= nlines) + return # ignore any remaining columns + if (g_next_l (fd, Memc[lbuf], SZ_LONG_LINE, + linenum) == EOF) { + done = true + return + } + n = n + 1 + ip = 1 + } + nchar = ctowrd (Memc[lbuf], ip, Memc[str], SZ_LINE) + if (nchar > 0) + call tbaptt (tp, cptr[col], rownum, + Memc[str], nchar, i, 1) + } + } + } + # Skip extra lines if all columns gotten in fewer than nlines lines. + do k = n+1, nlines { + iferr (stat = g_next_l (fd, Memc[lbuf], SZ_LONG_LINE, linenum)) + break + } + + call sfree (sp) +end + +# tcr_check_eol -- check for end of data +# This routine checks whether the remainder of the line contains anything +# other than whitespace and comments. If it does, a warning is printed. + +procedure tcr_check_eol (lbuf, linenum) + +char lbuf[ARB] # i: input line +int linenum # i: line number for warning message +#-- +int ip # loop index into lbuf +bool line_empty # true if the line is empty +bool done # loop termination flag + +begin + line_empty = false + + ip = 1 + done = false + while (!done) { + if (lbuf[ip] == ' ' || lbuf[ip] == '\t') { # skip whitespace + ip = ip + 1 + } else if (lbuf[ip] == '\n' || lbuf[ip] == EOS) { + line_empty = true + done = true + } else if (lbuf[ip] == '#') { + line_empty = true + done = true + } else { + line_empty = false + done = true + } + } + + if (!line_empty) { + call eprintf ("out of synch or extra data in line %d\n") + call pargi (linenum) + } +end + +# tcr_nelem -- separate array length from data type +# This routine takes a character string as input and returns the data +# type, total array length, dimension of array, and length of each axis. +# The syntax for axis lengths is numbers separated by commas, enclosed in +# brackets or parentheses, following the data type. For example, a 3-D +# array of 8-byte character strings with axis lengths of 30, 70, and 5 +# would be specified as ch*8[30,70,5]. The first axis is the most rapidly +# varying (i.e. Fortran notation). +# +# The output data type is the usual integer code, e.g. TY_REAL, except +# that for a character string of length N the code is -N. This is the +# data type that would be given as input to tbcdef. The default data +# type is real (TY_REAL). + +procedure tcr_nelem (chdtype, ndim, axlen, maxdim, nelem, dtype) + +char chdtype[ARB] # i: data type and dimensions +int ndim # o: dimension of array +int axlen[maxdim] # o: length of each axis of array +int maxdim # i: size of array axlen +int nelem # o: total number of elements in array +int dtype # o: data type of column for input to tbcdef +#-- +char temp[SZ_DTYPE] # scratch for copy of chdtype +char lbracket # '[' +char lparen # '(' +char endchar # ']' or ')', as appropriate +int indexb, indexp # locations of '[' and '(' in chdtype +int ip, ctoi() +int i, length # current dimension and axis length +bool done # to stop loop over dimensions +int stridx() +string errmessage "data type `%s':\n" + +begin + lparen = '(' + lbracket = '[' + + ndim = 1 # initial values + nelem = 1 + do i = 1, maxdim + axlen[i] = 1 + + if (chdtype[1] == EOS) { + dtype = TY_REAL # default + return + } + + call strcpy (chdtype, temp, SZ_DTYPE) + indexb = stridx (lbracket, chdtype) # "[" found? + indexp = stridx (lparen, chdtype) # "(" found? + done = false + if (indexb > 0 && indexp > 0) { + call eprintf (errmessage) + call pargstr (chdtype) + call error (1, "can't include both '[' and '('") + } else if (indexb > 0) { + endchar = ']' + ip = indexb + temp[ip] = EOS # now temp is just the data type + } else if (indexp > 0) { + endchar = ')' + ip = indexp + temp[ip] = EOS + } else { + done = true # don't try to extract array size + } + + # Convert the string to integer code (e.g. "r" --> TY_REAL). + iferr { + call tbbtyp (temp, dtype) + } then { + call eprintf (errmessage) + call pargstr (chdtype) + call erract (EA_ERROR) + } + + # Read axis lengths from brackets, if given. + i = 0 + ip = ip + 1 # skip over '[' + while (!done) { + + if (ctoi (chdtype, ip, length) < 1) { + call eprintf (errmessage) + call pargstr (chdtype) + call error (1, "syntax error") + + } + + i = i + 1 # increment dimension + if (i > maxdim) { + call eprintf (errmessage) + call pargstr (chdtype) + call error (1, "dimension is too high") + } + + if (length <= 0) { + call eprintf (errmessage) + call pargstr (chdtype) + call error (1, "axis lengths must be positive") + } + + ndim = i + axlen[ndim] = length + nelem = nelem * length + + if (chdtype[ip] == ',') { # separator between dimensions + ip = ip + 1 + } else if (chdtype[ip] == endchar) { # ']' or ')' + done = true + } else if (chdtype[ip] == EOS) { + call eprintf (errmessage) + call pargstr (chdtype) + call eprintf ("info: missing `%c' assumed\n") + call pargc (endchar) + done = true + } + } +end + +# tcr_ctoi -- ctoi, ignoring "+" sign +# This calls ctoi after skipping over any whitespace and/or a plus sign. +# Note that we allow whitespace after the sign as well as before. This +# is reasonable because we know (from the cdfile) that we're getting an +# integer rather than an arbitrary character string. +# +# After reading an integer value, if the next character in the input +# string is not whitespace and not the end of the line, the word will be +# reread from the input string as a double. If the value is actually +# an integer, even though the string may contain a decimal point or an +# exponent (e.g. "5." or "1.e2"), the integer will be returned as the +# value of n. If the value has a fractional part, that's an error. + +int procedure tcr_ctoi (input, ip, n, linenum) + +char input[ARB] # i: input string +int ip # io: starting/ending index in INPUT +int n # o: value read from string +int linenum # i: line number for possible error message +#-- +pointer sp, word # in case value is floating point +int i # local copy of integer value from string +int nvals # value returned by ctoi +bool positive # true if value is positive +int ctoi(), ctod(), ctowrd() +int ip_save # so we can call ctod() or ctowrd() +double x + +begin + positive = true # initial value + + while (IS_WHITE(input[ip])) # skip leading whitespace + ip = ip + 1 + + if (input[ip] == '+') # ignore "+" sign + ip = ip + 1 + + if (input[ip] == '-') { # make note of "-" sign + ip = ip + 1 + positive = false + } + + ip_save = ip + + nvals = ctoi (input, ip, i) + + # Allow for the possibility that the buffer contains a floating + # point value. + if (!IS_WHITE(input[ip]) && input[ip] != EOS) { + + # Conversion to int was terminated before the end of the word. + ip = ip_save + nvals = ctod (input, ip, x) + if (nvals > 0) { + i = int (x) + if (x != double(i)) { + # There is a fractional part; this is an error. + call smark (sp) + call salloc (word, SZ_FNAME, TY_CHAR) + ip = ip_save + nvals = ctowrd (input, ip, Memc[word], SZ_FNAME) + call eprintf ("`%s' in line %d is not an integer\n") + call pargstr (Memc[word]) + call pargi (linenum) + call error (1, "data type conflict with cdfile") + } + } + } + + if (nvals < 1) + n = INDEFI + else if (positive) + n = i + else + n = -i + + return (nvals) +end diff --git a/pkg/utilities/nttools/tdelete.par b/pkg/utilities/nttools/tdelete.par new file mode 100644 index 00000000..1397c29a --- /dev/null +++ b/pkg/utilities/nttools/tdelete.par @@ -0,0 +1,5 @@ +table,s,a,"",,,"list of tables to be deleted" +verify,b,h,no,,,verify operation before deleting each table? +default_action,b,h,yes,,,default delete action for verify query +go_ahead,b,q,yes,,," ?" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/tdiffer.par b/pkg/utilities/nttools/tdiffer.par new file mode 100644 index 00000000..b97ba246 --- /dev/null +++ b/pkg/utilities/nttools/tdiffer.par @@ -0,0 +1,6 @@ +intable1,f,a,,,,name of the first table +intable2,f,a,,,,name of the second table +outtable,s,a,,,,name of output table +colnam1,s,a,,,,name of columns in first table +colnam2,s,a,,,,name of columns in second table +mode,s,h,"a",,, diff --git a/pkg/utilities/nttools/tdiffer/mkpkg b/pkg/utilities/nttools/tdiffer/mkpkg new file mode 100644 index 00000000..93240165 --- /dev/null +++ b/pkg/utilities/nttools/tdiffer/mkpkg @@ -0,0 +1,12 @@ +# Update the tdiffer application code in the ttools package library +# Author: B.Simon, 14-JUN-88 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + tbldiff.x + tdiffer.x + ; diff --git a/pkg/utilities/nttools/tdiffer/tbldiff.x b/pkg/utilities/nttools/tdiffer/tbldiff.x new file mode 100644 index 00000000..b6ee7db4 --- /dev/null +++ b/pkg/utilities/nttools/tdiffer/tbldiff.x @@ -0,0 +1,99 @@ +include + +# TBL_DIFF -- Find rows in the first table which are not in the second +# +# B.Simon 15-Jun-88 First Code +# B.Simon 05-Feb-90 Revised to use tbtsrt and tbrcmp + +procedure tbl_diff (tp1, tp2, otp, nptr, col1, col2) + +pointer tp1 # i: Table descriptor of first input table +pointer tp2 # i: Table descriptor of second input table +pointer otp # i: Output table descriptor +int nptr # i: Number of column pointers +pointer col1[ARB] # i: Array of column pointers for first table +pointer col2[ARB] # i: Array of column pointers for second table +#-- +bool fold +int irow1, irow2, nrow1, nrow2, order, orow, iptr +pointer sp, colname, row1, row2, ocol + +int tbrcmp() + +begin + # Allocate dynamic memory for column name + + call smark (sp) + call salloc (colname, SZ_COLNAME, TY_CHAR) + + # Sort the array on the selected columns. + + fold = false + call allrows (tp1, nrow1, row1) + call allrows (tp2, nrow2, row2) + + call tbtsrt (tp1, nptr, col1, fold, nrow1, Memi[row1]) + call tbtsrt (tp2, nptr, col2, fold, nrow2, Memi[row2]) + + # Get the column pointers to compare on in the output tables + + call malloc (ocol, nptr, TY_INT) + do iptr = 1, nptr { + call tbcigt (col1[iptr], TBL_COL_NAME, Memc[colname], SZ_COLNAME) + call tbcfnd (otp, Memc[colname], Memi[ocol+iptr-1], 1) + } + + # Search for rows in first table which are not in the second + + orow = 1 + irow1 = 0 + irow2 = 0 + + while (irow1 < nrow1 && irow2 < nrow2) { + + # Copy rows from both tables into output table + + call tbrcpy (tp1, otp, Memi[row1+irow1], orow) + call tbrcsc (tp2, otp, col2, Memi[ocol], Memi[row2+irow2], + orow+1, nptr) + + # Update row indices and add row1 to output table + # if it is not in the second table + + order = tbrcmp (otp, nptr, Memi[ocol], fold, orow, orow+1) + + switch (order) { + case -1: + irow1 = irow1 + 1 + orow = orow + 1 + case 0: + irow1 = irow1 + 1 + case 1: + irow2 = irow2 + 1 + } + } + + # Delete extra rows from output table + + if (order < 0) + call tbrdel (otp, orow, orow) + else + call tbrdel (otp, orow, orow+1) + + # Add remaining rows of first table to output table + + while (irow1 < nrow1) { + call tbrcpy (tp1, otp, Memi[row1+irow1], orow) + irow1 = irow1 + 1 + orow = orow + 1 + } + + + # Free dynamic memory + + call mfree (row1, TY_INT) + call mfree (row2, TY_INT) + call mfree (ocol, TY_INT) + call sfree (sp) + +end diff --git a/pkg/utilities/nttools/tdiffer/tdiffer.x b/pkg/utilities/nttools/tdiffer/tdiffer.x new file mode 100644 index 00000000..9c30e82f --- /dev/null +++ b/pkg/utilities/nttools/tdiffer/tdiffer.x @@ -0,0 +1,92 @@ +include + +define SYNTAX 1 + +# TDIFFER -- Create a new table which is the difference of two old tables +# +# B.Simon 14-Jun-1988 First Code +# Phil Hodge 7-Sep-1988 Change parameter names for tables. +# Phil Hodge 8-Apr-1999 Call tbfpri. + +procedure t_tdiffer() + +pointer tab1 # First table +pointer tab2 # Second table +pointer outtab # Output table +pointer colnam1 # Columns to match in first table +pointer colnam2 # Columns to match in second table +#-- +int nptr1, nptr2, ncol1, ncol2 +int phu_copied # set by tbfpri and ignored +pointer sp, tp1, tp2, otp, col1, col2 + +string notfound "Column(s) not found in table" +string colnumerr "Number of columns do not agree" + +int tbpsta() +pointer tbtopn() + +begin + # Allocate stack memory for strings + + call smark (sp) + call salloc (tab1, SZ_FNAME, TY_CHAR) + call salloc (tab2, SZ_FNAME, TY_CHAR) + call salloc (outtab, SZ_FNAME, TY_CHAR) + call salloc (colnam1, SZ_LINE, TY_CHAR) + call salloc (colnam2, SZ_LINE, TY_CHAR) + + # Read the task parameters + + call clgstr ("intable1", Memc[tab1], SZ_LINE) + call clgstr ("intable2", Memc[tab2], SZ_LINE) + call clgstr ("outtable", Memc[outtab], SZ_LINE) + call clgstr ("colnam1", Memc[colnam1], SZ_LINE) + call clgstr ("colnam2", Memc[colnam2], SZ_LINE) + + # Open the tables and create column arrays + + tp1 = tbtopn (Memc[tab1], READ_ONLY, NULL) + ncol1 = tbpsta (tp1, TBL_NCOLS) + call malloc (col1, ncol1, TY_INT) + + tp2 = tbtopn (Memc[tab2], READ_ONLY, NULL) + ncol2 = tbpsta (tp2, TBL_NCOLS) + call malloc (col2, ncol2, TY_INT) + + # Open output table and copy header(s) from first table + + call tbfpri (Memc[tab1], Memc[outtab], phu_copied) + otp = tbtopn (Memc[outtab], NEW_COPY, tp1) + call tbtcre (otp) + call tbhcal (tp1, otp) + + # Create two arrays of column pointers from the column templates + + call tctexp (tp1, Memc[colnam1], ncol1, nptr1, Memi[col1]) + if (nptr1 == 0) + call error (SYNTAX, notfound) + + call tctexp (tp2, Memc[colnam2], ncol2, nptr2, Memi[col2]) + if (nptr2 == 0) + call error (SYNTAX, notfound) + + if (nptr1 != nptr2) + call error (SYNTAX, colnumerr) + + # Retrieve the indices of the rows of the first table which are + # not in the second table + + call tbl_diff (tp1, tp2, otp, nptr1, Memi[col1], Memi[col2]) + + # Close the tables and free dynamic memory + + call tbtclo (tp1) + call tbtclo (tp2) + call tbtclo (otp) + + call mfree (col1, TY_INT) + call mfree (col2, TY_INT) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tdump.par b/pkg/utilities/nttools/tdump.par new file mode 100644 index 00000000..f7e5814a --- /dev/null +++ b/pkg/utilities/nttools/tdump.par @@ -0,0 +1,8 @@ +table,s,a,"",,,"name of table to dump" +cdfile,s,h,"STDOUT",,,"output file for column definitions" +pfile,s,h,"STDOUT",,,"output file for header parameters" +datafile,s,h,"STDOUT",,,"output file for table data" +columns,s,h,"",,,"list of columns to be dumped" +rows,s,h,"-",,,"range of rows to print" +pwidth,i,h,-1,-1,,"output page width" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/tedit.par b/pkg/utilities/nttools/tedit.par new file mode 100644 index 00000000..97f705e5 --- /dev/null +++ b/pkg/utilities/nttools/tedit.par @@ -0,0 +1,6 @@ +table,f,a,,,,Input table +columns,s,h," ",,,List of columns to edit +silent,b,h,no,,,Don't ring bell? +rdonly,b,h,no,,,Edit table read only? +inplace,b,h,no,,,Edit table in place? +mode,s,h,al diff --git a/pkg/utilities/nttools/tedit/bell.x b/pkg/utilities/nttools/tedit/bell.x new file mode 100644 index 00000000..dd939e4e --- /dev/null +++ b/pkg/utilities/nttools/tedit/bell.x @@ -0,0 +1,19 @@ +# RING_BELL -- Ring the bell to wake up the user + +procedure ring_bell () + +bool silent # i: do not ring bell +#-- +bool ring # variable used to hold the value of silent + +begin + if (ring) + call ps_beep + return + + entry init_bell (silent) + + ring = ! silent + return + +end diff --git a/pkg/utilities/nttools/tedit/command.com b/pkg/utilities/nttools/tedit/command.com new file mode 100644 index 00000000..391c025e --- /dev/null +++ b/pkg/utilities/nttools/tedit/command.com @@ -0,0 +1,6 @@ +# COMMAND.COM -- Global variables used by commands + +int direction # Search direction +char search_exp[SZ_LINE] # Search expression + +common /search/ direction, search_exp diff --git a/pkg/utilities/nttools/tedit/command.h b/pkg/utilities/nttools/tedit/command.h new file mode 100644 index 00000000..5e4956f1 --- /dev/null +++ b/pkg/utilities/nttools/tedit/command.h @@ -0,0 +1,21 @@ +# COMMAND.H -- Commands which can be executed from the prompt line + +define TED_CMDLIST "|add|copy|delete|exit|find|goto|help|insert|lower|next|\ +quit|set|substitute|upper|" + +define TED_ADD 1 +define TED_COPY 2 +define TED_DELETE 3 +define TED_EXIT 4 +define TED_FIND 5 +define TED_GOTO 6 +define TED_HELP 7 +define TED_INSERT 8 +define TED_LOWER 9 +define TED_NEXT 10 +define TED_QUIT 11 +define TED_SET 12 +define TED_SUBSTITUTE 13 +define TED_UPPER 14 + + diff --git a/pkg/utilities/nttools/tedit/command.x b/pkg/utilities/nttools/tedit/command.x new file mode 100644 index 00000000..185ad103 --- /dev/null +++ b/pkg/utilities/nttools/tedit/command.x @@ -0,0 +1,1458 @@ +include +include "screen.h" +include "table.h" +include "paste.h" +include "field.h" +include "command.h" + +define BLANK ' ' +define SQUOTE '\'' +define DQUOTE '"' +define HARMLESS 0.11 +define MAXROWS 10000 + +# ADD_CMD -- Add a column or row to the table + +procedure add_cmd (scr, nargs, arglist) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +#-- +int which, iarg +pointer sp, what, tab + +string options "|row|column|" +string notadded "Cannot add column to table" + +int strdic(), option_cmd() + +begin + call smark (sp) + call salloc (what, SZ_LINE, TY_CHAR) + + tab = TED_TABLE(scr) + + # Determine whether a row or column should be added + + which = option_cmd (options, nargs, arglist) + + while (which == 0) { + iarg = nargs + 1 + call getstr_cmd ("Add row or column", iarg, nargs, arglist, + Memc[what], SZ_LINE) + which = strdic (Memc[what], Memc[what], SZ_LINE, options) + } + + # Call the appropriate routine + + if (which == 1) { + call addrow_cmd (scr, nargs, arglist) + + } else if (TED_ALLCOLS(tab) == YES) { + call addcol_cmd (scr, nargs, arglist) + + } else { + call warn1_prompt (scr, notadded) + } + + call sfree (sp) +end + +# ADDCOL_CMD -- Add a new column to the table + +procedure addcol_cmd (scr, nargs, arglist) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +#-- +int iarg, type, icol, ncol, code, clen +pointer sp, cname, cunits, ftnfmt, sppfmt, ctype, errmsg +pointer tab, paste, tp, cp + +string nowrite "Cannot change read only table" +string nullcol "No column added to table" +string nocolumn "Cannot add column" +string nopaste "Could not add column to paste table" + +int errget(), tbcigi(), strlen() +pointer tbcnum() + +begin + # Check for read only table + + tab = TED_TABLE(scr) + if (TED_READONLY(tab) == YES) { + call warn1_prompt (scr, nowrite) + return + } + + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (cname, SZ_COLNAME, TY_CHAR) + call salloc (cunits, SZ_COLUNITS, TY_CHAR) + call salloc (ftnfmt, SZ_COLFMT, TY_CHAR) + call salloc (sppfmt, SZ_COLFMT, TY_CHAR) + call salloc (ctype, SZ_FNAME, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Get table descriptors from screen structure + + paste = TED_PASTE(scr) + tp = TED_TABPTR(tab) + + # Get parameters defining new column + + call getstr_cmd ("Column name", 2, nargs, arglist, + Memc[cname], SZ_COLNAME) + + if (Memc[cname] == EOS) { + call write_prompt (scr, NO, nullcol) + return + } + + iarg = 3 + repeat { + call getstr_cmd ("Column type (r,d,i,s,b,ch*n)", iarg, nargs, + arglist, Memc[ctype], SZ_FNAME) + + iferr (call tbbtyp (Memc[ctype], type)) { + iarg = nargs + 1 + call ring_bell + } else { + break + } + } + + iarg = 4 + repeat { + call getstr_cmd ("Column print format", iarg, nargs, arglist, + Memc[ftnfmt], SZ_COLFMT) + call tbbftp (Memc[ftnfmt], Memc[sppfmt]) + + if (Memc[sppfmt] == EOS && Memc[ftnfmt] != EOS) { + iarg = nargs + 1 + call ring_bell + } else { + break + } + } + + call getstr_cmd ("Column units", 5, nargs, arglist, + Memc[cunits], SZ_COLUNITS) + + # Add new column to paste table + + if (paste != NULL) { + iferr { + call tbcdef (TED_PSTPTR(paste), cp, Memc[cname], Memc[cunits], + Memc[sppfmt], type, 1, 1) + } then { + call warn1_prompt (scr, nopaste) + return + } + } + + # Add new column to table + + iferr { + call tbcdef (tp, cp, Memc[cname], Memc[cunits], + Memc[sppfmt], type, 1, 1) + } then { + code = errget (Memc[errmsg], SZ_LINE) + call warn2_prompt (scr, nocolumn, Memc[errmsg]) + return + } + + # Free old arrays containing table info and create new ones + + ncol = TED_NCOLS(tab) + 1 + call mfree (TED_COLARY(tab), TY_INT) + call mfree (TED_TYPARY(tab), TY_INT) + call mfree (TED_LENARY(tab), TY_INT) + + call malloc (TED_COLARY(tab), ncol, TY_INT) + call malloc (TED_TYPARY(tab), ncol, TY_INT) + call malloc (TED_LENARY(tab), ncol, TY_INT) + + # Load new column info into arrays + + TED_DIRTY(tab) = YES + TED_NCOLS(tab) = ncol + do icol = 1, ncol { + cp = tbcnum (tp, icol) + TED_COLPTR(tab, icol) = cp + TED_COLTYPE (tab,icol) = tbcigi (cp, TBL_COL_DATATYPE) + clen = tbcigi (cp, TBL_COL_FMTLEN) + call tbcigt (cp, TBL_COL_NAME, Memc[cname], SZ_COLNAME) + TED_COLLEN(tab,icol) = max (clen, strlen(Memc[cname])) + } + + # Redraw screen + + call move_screen (scr, LEFT, YES) + call sfree (sp) +end + +# ADDROW_CMD -- Add null rows to the table + +procedure addrow_cmd (scr, nargs, arglist) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +#-- +int nrow, row, numadd +pointer tab, tptr + +string nowrite "Cannot change read only table" + +int tbpsta() + +begin + # Check for read only table + + tab = TED_TABLE(scr) + if (TED_READONLY(tab) == YES) { + call warn1_prompt (scr, nowrite) + return + } + + # Get current number of rows in the table + + tptr = TED_TABPTR(tab) + nrow = tbpsta (tptr ,TBL_NROWS) + + # Read command parameters + + call getint_cmd ("Add after row", 2, nargs, arglist, + TED_CURROW(scr), 0, nrow, row) + + call getint_cmd ("Number of rows to add", 3, nargs, arglist, + 1, 0, INDEFI, numadd) + + # Return if number of rows to add is zero + + if (numadd == 0) + return + + # Add null rows to table + + TED_DIRTY(tab) = YES + if (row == nrow) { + call tbtwer (tptr, row+numadd) + + } else { + call tbrsft (tptr, row, numadd) + call tbrnll (tptr, row+1, row+numadd) + } + + # Reset label width if table has grown a lot + + TED_LABWIDTH(tab) = log10 (real(nrow + numadd + 1000)) + 1.0 + TED_LABWIDTH(tab) = max (6, TED_LABWIDTH(tab)) + + # Redraw screen + + if (row <= TED_HIROW(scr)) + call move_screen (scr, LEFT, YES) + +end + +# COPY_CMD -- Copy a range of lines to the paste buffer + +procedure copy_cmd (scr, nargs, arglist) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +#-- +bool append +int nrow, first, last, irow, orow, ncopy +pointer tab, paste + +int tbpsta(), option_cmd() +pointer opn_paste() + +begin + tab = TED_TABLE(scr) + paste = TED_PASTE(scr) + nrow = tbpsta (TED_TABPTR(tab) ,TBL_NROWS) + + # Open paste buffer if not yet open + + if (paste == NULL) { + paste = opn_paste (scr) + if (paste == NULL) + return + } + + # Read copy command parameters + + append = option_cmd ("|append|", nargs, arglist) != 0 + + call getint_cmd ("First row to copy", 2, nargs, arglist, + TED_CURROW(scr), 1, nrow, first) + call getint_cmd ("Last row to copy", 3, nargs, arglist, + TED_CURROW(scr), 1, nrow, last) + + if (first < last) { + irow = first + ncopy = last - first + 1 + } else { + irow = last + ncopy = first - last + 1 + } + + if (append) { + orow = TED_PSTROWS(paste) + 1 + TED_PSTROWS(paste) = TED_PSTROWS(paste) + ncopy + } else { + orow = 1 + TED_PSTROWS(paste) = ncopy + } + + call move_paste (TED_TABPTR(tab), TED_PSTPTR(paste), irow, orow, ncopy) + +end + +# COUNT_CMD -- Count the number of words in a string + +int procedure count_cmd (str) + +char str[ARB] # i: String containing words +#-- +char ch +int count, ic + +begin + # The absolute value of count is the number of the current + # word of the string, count is negative if we are currently + # between words. + + count = 0 + + # Loop over all characters in the string + + for (ic = 1 ; str[ic] != EOS; ic = ic + 1) { + ch = str[ic] + + if (count > 0) { + if (ch <= ' ') + count = - count + + } else if (ch > ' ') { + count = - count + 1 + } + } + + return (abs(count)) +end + +# DELETE_CMD -- Delete a range of lines, copy them to the paste buffer + +procedure delete_cmd (scr, nargs, arglist) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +#-- +bool append +int nrow, first, last, irow, orow, ncopy +pointer tab, tptr, paste + +string nowrite "Cannot change read only table" + +int tbpsta(), option_cmd() +pointer opn_paste() + +begin + # Check for read only table + + tab = TED_TABLE(scr) + tptr = TED_TABPTR(tab) + if (TED_READONLY(tab) == YES) { + call warn1_prompt (scr, nowrite) + return + } + + # Get paste table + + paste = TED_PASTE(scr) + nrow = tbpsta (tptr ,TBL_NROWS) + + if (paste == NULL) { + paste = opn_paste (scr) + if (paste == NULL) + return + } + + # Read command parameters + + append = option_cmd ("|append|", nargs, arglist) != 0 + + call getint_cmd ("First row to delete", 2, nargs, arglist, + TED_CURROW(scr), 1, nrow, first) + call getint_cmd ("Last row to delete", 3, nargs, arglist, + TED_CURROW(scr), 1, nrow, last) + + if (first < last) { + irow = first + } else { + irow = last + last = first + first = irow + } + + # Copy deleted rows to paste table, then delete from original table + + ncopy = last - first + 1 + + if (append) { + orow = TED_PSTROWS(paste) + 1 + TED_PSTROWS(paste) = TED_PSTROWS(paste) + ncopy + } else { + orow = 1 + TED_PSTROWS(paste) = ncopy + } + + call move_paste (tptr, TED_PSTPTR(paste), irow, orow, ncopy) + call tbrdel (tptr, first, last) + TED_DIRTY(tab) = YES + + # Add single blank row if all rows were deleted + + nrow = nrow - ncopy + if (nrow < 1) { + nrow = 1 + call tbtwer (tptr, 1) + } + + # Set current row number and redraw screen + + if (TED_CURROW(scr) >= first && TED_CURROW(scr) <= last) + TED_CURROW(scr) = max (1, first-1) + + TED_CURROW(scr) = min (TED_CURROW(scr), nrow) + + if (first <= TED_HIROW(scr)) + call move_screen (scr, LEFT, YES) + +end + +# EXIT_CMD -- Process the exit command + +procedure exit_cmd (scr, nargs, arglist) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +#-- +int iscr +pointer scr2 + +int get_window() + +begin + for (iscr = 1; get_window (iscr, scr2) != EOF; iscr = iscr + 1) + call del_screen (scr2, YES) + +end + +# FIND_CMD -- Find the row which makes the expression true + +procedure find_cmd (scr, nargs, arglist) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +#-- +include "command.com" + +int first, last, row +pointer tab + +string badexpr "Syntax error" +string blankexp "No expression given" +string notfound "No rows matched expression" + +int tbpsta(), option_cmd(), count_cmd(), tbl_search() + +begin + tab = TED_TABLE(scr) + + # Get arguments of find command + + direction = option_cmd ("|forward|backwards|", nargs, arglist) + if (direction == 0) + direction = 1 + + call getstr_cmd ("Find expression", 2, nargs, arglist, + search_exp, SZ_LINE) + + if (count_cmd (search_exp) == 0) { + call warn1_prompt (scr, blankexp) + search_exp[1] = EOS + return + } + + # Set limits for search + + if (direction == 2) { + first = TED_CURROW(scr) + last = 1 + } else { + first = TED_CURROW(scr) + last = tbpsta (TED_TABPTR(tab) ,TBL_NROWS) + } + + # Perform search and report results + + row = tbl_search (TED_TABPTR(tab), search_exp, first, last) + + if (row == ERR) { # syntax error + # Redraw screen to hide error message from evexpr() + call move_screen (scr, LEFT, YES) + call warn2_prompt (scr, badexpr, search_exp) + search_exp[1] = EOS + + } else if (row == 0) { # row not found + call write_prompt (scr, NO, notfound) + + } else { # row found, update screen descriptor + TED_CURROW(scr) = row + } + +end + +# FUNC_CMD -- Change a single column using a function + +procedure func_cmd (scr, nargs, arglist, func) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +extern func # i: Function which modifies a string in place +#-- +int col, irow, nrow, len +pointer sp, defcol, colstr, tab, cptr, tptr + +string nowrite "Cannot change read only table" +string numeric "Cannot change numeric column" + +int tbpsta() + +begin + # Check for read only table + + tab = TED_TABLE(scr) + if (TED_READONLY(tab) == YES) { + call warn1_prompt (scr, nowrite) + return + } + + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (defcol, SZ_COLNAME, TY_CHAR) + + # Get name of column + + cptr = TED_COLPTR(tab, TED_CURCOL(scr)) + call tbcigt (cptr, TBL_COL_NAME, Memc[defcol], SZ_COLNAME) + + call getcol_cmd ("Column to change", 2, nargs, arglist, tab, + Memc[defcol], col) + + # Make sure it's a string column + + if (TED_COLTYPE(tab,col) > 0) { + call warn1_prompt (scr, numeric) + + } else { + + # Allocate array to hold field + + len = - TED_COLTYPE(tab,col) + call salloc (colstr, len, TY_CHAR) + + # Get current number of rows in the table + + tptr = TED_TABPTR(tab) + cptr = TED_COLPTR(tab, col) + nrow = tbpsta (tptr ,TBL_NROWS) + + # Retrieve each field and convert case + + TED_DIRTY(tab) = YES + do irow = 1, nrow { + call tbegtt (tptr, cptr, irow, Memc[colstr], len) + call func (Memc[colstr]) + call tbeptt (tptr, cptr, irow, Memc[colstr]) + } + } + + # Redraw screen if column is displayed + + if (col >= TED_LOCOL(scr) && col <= TED_HICOL(scr)) + call move_screen (scr, LEFT, YES) + + call sfree (sp) + +end + +# GETCOL_CMD -- Get a column name from the argument list + +procedure getcol_cmd (argname, index, nargs, arglist, tab, defcol, icol) + +char argname[ARB] # i: Argument name (used as prompt if not found) +int index # i: Index to string within argument list +int nargs # i: Number of arguments in list +char arglist[ARB] # i: List of arguments, separated by EOS characters +pointer tab # i: Table descriptor +char defcol[ARB] # i: Default column name (or EOS) +int icol # o: Column number +#-- +int ic, ncol, jcol, iarg, junk +pointer sp, cname, cprompt, colptr[1] + +int ctoi() + +begin + # Allocate memory for temporary strings + + call smark (sp) + call salloc (cname, SZ_COLNAME, TY_CHAR) + call salloc (cprompt, SZ_LINE, TY_CHAR) + + # Get the string containing the column name + + if (defcol[1] == EOS) { + call strcpy (argname, Memc[cprompt], SZ_LINE) + } else { + call sprintf (Memc[cprompt], SZ_LINE, "%s (%s)") + call pargstr (argname) + call pargstr (defcol) + } + + call getstr_cmd (Memc[cprompt], index, nargs, arglist, + Memc[cname], SZ_COLNAME) + + if (Memc[cname] == EOS) + call strcpy (defcol, Memc[cname], SZ_COLNAME) + + # Loop until valid column name found + + icol = 0 + while (icol == 0) { + colptr[1] = NULL + Memc[cprompt] = EOS + + # Get a column pointer from the column template + + iferr { + call tctexp (TED_TABPTR(tab), Memc[cname], 1, ncol, colptr) + } then { + # More than one column matches the name + call strcpy ("Ambiguous column name. ", Memc[cprompt], SZ_LINE) + + } else { + # If one name matched, check against list of column pointers + + if (ncol == 1) { + for (jcol = 1; jcol <= TED_NCOLS(tab); jcol = jcol + 1) { + if (colptr[1] == TED_COLPTR(tab,jcol)) { + icol = jcol + break + } + } + } + + # Convert name to number, see if number is within range + + if (icol == 0) { + ic = 1 + junk = ctoi (Memc[cname], ic, icol) + + if (Memc[cname+ic-1] != EOS) + icol = 0 + else if (icol < 1 || icol > TED_NCOLS(tab)) + icol = 0 + } + + if (icol == 0) + call strcpy ("Column not found. ", Memc[cprompt], SZ_LINE) + } + + # If column not matched, read new name interactively + + if (icol == 0) { + iarg = nargs + 1 + call strcat (argname, Memc[cprompt], SZ_LINE) + + call getstr_cmd (Memc[cprompt], iarg, nargs, arglist, + Memc[cname], SZ_FNAME) + + if (Memc[cname] == EOS) + call strcpy (defcol, Memc[cname], SZ_COLNAME) + } + } + + call sfree (sp) +end + +# GETINT_CMD -- Get an integer from the argument list + +procedure getint_cmd (argname, index, nargs, arglist, defval, + minval, maxval, value) + +char argname # i: Argument name (used as prompt if not found) +int index # i: Index to string within argument list +int nargs # i: Number of arguments in list +char arglist[ARB] # i: List of arguments, separated by EOS characters +int defval # i: Default legal value (or INDEFI) +int minval # i: Minimum legal value (or INDEFI) +int maxval # i: Maximum legal value (or INDEFI) +int value # o: Output value +#-- +int ic, iarg, junk +pointer sp, valstr, prompt + +string typemsg "Please enter a number. " +string rangemsg "Out of range (%d - %d). " + +int ctoi() + +begin + # Allocate memory for temporary strings + + call smark (sp) + call salloc (valstr, SZ_FNAME, TY_CHAR) + call salloc (prompt, SZ_LINE, TY_CHAR) + + # Get the string representing the value + + if (IS_INDEFI (defval)) { + call strcpy (argname, Memc[prompt], SZ_LINE) + } else { + call sprintf (Memc[prompt], SZ_LINE, "%s (%d)") + call pargstr (argname) + call pargi (defval) + } + + call getstr_cmd (Memc[prompt], index, nargs, arglist, + Memc[valstr], SZ_FNAME) + + if (Memc[valstr] == EOS) { + value = defval + } else { + ic = 1 + junk = ctoi (Memc[valstr], ic, value) + if (Memc[valstr+ic-1] != EOS) + value = INDEFI + } + + # Loop until valid value is found + + repeat { + if (IS_INDEFI(value)) { + call strcpy (typemsg, Memc[prompt], SZ_LINE) + + } else if ((value < minval && ! IS_INDEFI (minval)) || + (value > maxval && ! IS_INDEFI (maxval)) ) { + call sprintf (Memc[prompt], SZ_LINE, rangemsg) + call pargi (minval) + call pargi (maxval) + + } else { + break + } + + # If the string was not valid, get the value interactively + + iarg = nargs + 1 + call strcat (argname, Memc[prompt], SZ_LINE) + + call getstr_cmd (Memc[prompt], iarg, nargs, arglist, + Memc[valstr], SZ_FNAME) + + ic = 1 + junk = ctoi (Memc[valstr], ic, value) + if (Memc[valstr+ic-1] != EOS) + value = INDEFI + } + + call sfree (sp) +end + +# GETSTR_CMD -- Get a string from the command argument list + +procedure getstr_cmd (argname, index, nargs, arglist, str, maxch) + +char argname # i: Argument name (used as prompt if not found) +int index # i: Index to string within argument list +int nargs # i: Number of arguments in list +char arglist[ARB] # i: List of arguments, separated by EOS characters +char str[ARB] # o: Output string +int maxch # i: Maximum length of output string +#-- +int ic, jc, iarg +pointer sp, prompt + +string nullarg "getstr_cmd: null argument found in argument list" + +begin + # Allocate dynamic memory for prompt + + call smark (sp) + call salloc (prompt, SZ_LINE, TY_CHAR) + + # Read the argument interactively if not supplied by the user + # Otherwise, copy from the argument list string + + if (index > nargs) { + call strcpy (argname, Memc[prompt], SZ_LINE) + call strcat ("?", Memc[prompt], SZ_LINE) + + call read_prompt (Memc[prompt], str, maxch) + + } else { + # Skip over leading arguments + + ic = 1 + for (iarg = 1; iarg < index; iarg = iarg + 1) { + if (arglist[ic] == EOS) + call err1_prompt (nullarg) + + while (arglist[ic] != EOS) + ic = ic + 1 + ic = ic + 1 + } + + # Copy into output string + + for (jc = 1; jc <= maxch && arglist[ic] != EOS; jc = jc + 1) { + str[jc] = arglist[ic] + ic = ic + 1 + } + str[jc] = EOS + } + + call sfree (sp) +end + +# GOTO_CMD -- Process the goto command + +procedure goto_cmd (scr, nargs, arglist) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +#-- +int nrow, row, col +pointer sp, defcol, tab, cptr + +int tbpsta() + +string notable "No table associated with this screen" + +begin + # Allocate dynamic memory for column name + + call smark (sp) + call salloc (defcol, SZ_COLNAME, TY_CHAR) + + # Get number of rows in table + + tab = TED_TABLE(scr) + if (tab == NULL) + call err1_prompt (notable) + else + nrow = tbpsta (TED_TABPTR(tab), TBL_NROWS) + + cptr = TED_COLPTR(tab, TED_CURCOL(scr)) + call tbcigt (cptr, TBL_COL_NAME, Memc[defcol], SZ_COLNAME) + + # Get the row and column numbers + + call getint_cmd ("Go to row", 2, nargs, arglist, + TED_CURROW(scr), 1, nrow, row) + call getcol_cmd ("Go to column", 3, nargs, arglist, tab, + Memc[defcol], col) + + # Update screen descriptor + + TED_CURROW(scr) = row + TED_CURCOL(scr) = col + + call sfree (sp) +end + +# HELP_CMD -- Process the help command + +procedure help_cmd (scr, nargs, arglist) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +#-- + +begin + call help_screen (TED_WINDOW(scr)) + +end + +# INIT_CMD -- Initialize the global variables used by commands + +procedure init_cmd(silent) + +bool silent # i: do not ring bell when error occurs +#-- +include "command.com" + +begin + direction = 1 + search_exp[1] = EOS + call init_bell (silent) +end + +# INSERT_CMD -- Process an insert command + +procedure insert_cmd (scr, nargs, arglist) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +#-- +int irow, nrow +pointer tab, paste + +string nowrite "Cannot change read only table" +string nopaste "Paste buffer is empty" + +int tbpsta() +pointer opn_paste() + +begin + # Check for read only table + + tab = TED_TABLE(scr) + if (TED_READONLY(tab) == YES) { + call warn1_prompt (scr, nowrite) + return + } + + paste = TED_PASTE(scr) + nrow = tbpsta (TED_TABPTR(tab) ,TBL_NROWS) + + if (paste == NULL) { + paste = opn_paste (scr) + if (paste == NULL) + return + } + + # Get insert command parameters + + call getint_cmd ("Insert after row number", 2, nargs, arglist, + TED_CURROW(scr), 0, nrow, irow) + + # Check to see if there is something to insert + + if (TED_PSTROWS(paste) <= 0) { + call warn1_prompt (scr, nopaste) + return + } + + TED_DIRTY(tab) = YES + if (irow < nrow) + call tbrsft (TED_TABPTR(tab), irow+1, TED_PSTROWS(paste)) + + call move_paste (TED_PSTPTR(paste), TED_TABPTR(tab), + 1, irow+1, TED_PSTROWS(paste)) + + if (irow <= TED_HIROW(scr)) + call move_screen (scr, LEFT, YES) + +end + +# LOWER_CMD -- Convert a column to lower cse + +procedure lower_cmd (scr, nargs, arglist) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +#-- +extern strlwr + +begin + # A common routine handle both the lower and upper case + # commands, since they are so similar + + call func_cmd (scr, nargs, arglist, strlwr) +end + +# NEXT_CMD -- Repeat the search for an expression + +procedure next_cmd (scr, nargs, arglist) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +#-- +include "command.com" + +int dir, nrow, first, last, row +pointer tab + +string nofind "No previous find command" +string badexpr "Syntax error" +string notfound "No rows matched expression" + +int tbpsta(), option_cmd(), tbl_search() + +begin + tab = TED_TABLE(scr) + nrow = tbpsta (TED_TABPTR(tab) ,TBL_NROWS) + + # Make sure there was a previous find command + + if (search_exp[1] == EOS) { + call warn1_prompt (scr, nofind) + return + } + + # Get the command option + + dir = option_cmd ("|forward|backwards|", nargs, arglist) + if (dir != 0) + direction = dir + + # Set limits for search + + if (direction == 2) { + first = max (TED_CURROW(scr)-1, 1) + last = 1 + } else { + first = min (TED_CURROW(scr)+1, nrow) + last = nrow + } + + # Perform search and report results + + row = tbl_search (TED_TABPTR(tab), search_exp, first, last) + + if (row == ERR) { # syntax error + call warn2_prompt (scr, badexpr, search_exp) + search_exp[1] = EOS + + } else if (row == 0) { # row not found + call write_prompt (scr, NO, notfound) + + } else { # row found, update screen descriptor + TED_CURROW(scr) = row + } + +end + +# OPTION_CMD -- Get the command option + +int procedure option_cmd (optlist, nargs, arglist) + +char optlist[ARB] # i: List of legal options +int nargs # u: Number of command arguments +char arglist[ARB] # u: Argument list +#-- +int option, iarg, ic, jc, last[2] +pointer sp, arg1, arg2 + +int strdic() + +begin + # No option if number of arguments < 2 + if (nargs < 2) + return (0) + + # Allocate dynamic memory for optional argument + + call smark (sp) + call salloc (arg1, SZ_LINE, TY_CHAR) + call salloc (arg2, SZ_LINE, TY_CHAR) + + # Read optional argument, match against list of options + + call getstr_cmd ("Option", 2, nargs, arglist, Memc[arg1], SZ_LINE) + option = strdic (Memc[arg1], Memc[arg2], SZ_LINE, optlist) + + # If matched, remove option from argument list + + if (option != 0) { + ic = 1 + do iarg = 1, 2 { + while (arglist[ic] != EOS) + ic = ic + 1 + last[iarg] = ic + ic = ic + 1 + } + + ic = last[1] + jc = last[2] + repeat { + ic = ic + 1 + jc = jc + 1 + arglist[ic] = arglist[jc] + } until (arglist[jc] == EOS && arglist[jc-1] == EOS) + + nargs = nargs - 1 + } + + call sfree (sp) + return (option) + +end + +# PARSE_CMD -- Parse a command string + +procedure parse_cmd (command, code, nargs, arglist, maxch) + +char command[ARB] # i: Command to be parsed +int code # o: Command code (0 if unknown command) +int nargs # o: Number of arguments (including command name) +char arglist[ARB] # o: Array of arguments, packed into one string +int maxch # i: Declared length of arglist +#-- +int ic, jc, delim +pointer sp, temp + +string cmdlist TED_CMDLIST + +int strdic() + +begin + # Allocate temporary string for full command name + + call smark (sp) + call salloc (temp, SZ_FNAME, TY_CHAR) + + # Break command string into arguements + # Count the number of arguements + + jc = 1 + nargs = 0 + delim = EOS + for (ic = 1; command[ic] != EOS && jc <= maxch; ic = ic + 1) { + if (delim == EOS) { + if (command[ic] > BLANK) { + nargs = nargs + 1 + if (command[ic] == SQUOTE) { + delim = SQUOTE + } else if (command[ic] == DQUOTE) { + delim = DQUOTE + } else { + ic = ic - 1 # push back non-blank character + delim = BLANK + } + } + + } else if (delim == BLANK) { + if (command[ic] <= BLANK) { + arglist[jc] = EOS + jc = jc + 1 + delim = EOS + + } else { + arglist[jc] = command[ic] + jc = jc + 1 + } + + } else { + if (command[ic] == delim) { + arglist[jc] = EOS + jc = jc + 1 + delim = EOS + + } else { + arglist[jc] = command[ic] + jc = jc + 1 + } + } + } + arglist[jc] = EOS + + # Get the code which corresponds to the first arguement + # (the command name) + + if (nargs == 0) { + code = 0 + } else { + code = strdic (arglist, Memc[temp], SZ_FNAME, cmdlist) + } + + call sfree (temp) +end + +# QUIT_CMD -- Quit the editor without saving files + +procedure quit_cmd (scr, nargs, arglist) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +#-- +int iscr +pointer scr2 + +int get_window() + +begin + for (iscr = 1; get_window (iscr, scr2) != EOF; iscr = iscr + 1) + call del_screen (scr2, NO) + +end + +# SET_CMD -- Set a column to the value of an expression + +procedure set_cmd (scr, nargs, arglist) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +#-- +include "../tabvar.com" + +bool done +int col, irow, nrow, nbuf, coltype, exptype +pointer sp, defcol, expr, buffer, tab, cptr, tptr, code + +string nowrite "Cannot change read only table" +string syntax "Syntax error in expression" + +extern tabvar +int tbpsta() +pointer vex_compile() + +begin + # Check for read only table + + tab = TED_TABLE(scr) + if (TED_READONLY(tab) == YES) { + call warn1_prompt (scr, nowrite) + return + } + + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (defcol, SZ_COLNAME, TY_CHAR) + call salloc (expr, SZ_LINE, TY_CHAR) + + # Get name of column + + cptr = TED_COLPTR(tab, TED_CURCOL(scr)) + call tbcigt (cptr, TBL_COL_NAME, Memc[defcol], SZ_COLNAME) + + call getcol_cmd ("Column to change", 2, nargs, arglist, tab, + Memc[defcol], col) + + call getstr_cmd ("Expression", 3, nargs, arglist, + Memc[expr], SZ_LINE) + + # Get table info + + tptr = TED_TABPTR(tab) + cptr = TED_COLPTR(tab, col) + nrow = tbpsta (tptr, TBL_NROWS) + + coltype = TED_COLTYPE(tab,col) + if (coltype < 0) { + # String columns copy the expression verbatim + + TED_DIRTY(tab) = YES + do irow = 1, nrow + call tbeptt (tptr, cptr, irow, Memc[expr]) + + } else { + # Numeric columns use the expression evaluator + + iferr { + code = vex_compile (Memc[expr]) + } then { + call warn2_prompt (scr, syntax, Memc[expr]) + call sfree (sp) + return + } + + # Initialize common block used by tabvar() + + tabptr = tptr + firstrow = 1 + lastrow = MAXROWS + + done = false + nullval = HARMLESS + + repeat { + if (lastrow >= nrow) { + done = true + lastrow = nrow + } + + iferr { + call vex_eval (code, tabvar, nullval, exptype) + } then { + call warn2_prompt (scr, syntax, Memc[expr]) + call sfree (sp) + return + } + + nbuf = (lastrow - firstrow) + 1 + + # Copy results to column + + switch (coltype) { + case TY_BOOL, TY_SHORT, TY_INT, TY_LONG: + call malloc (buffer, nbuf, TY_INT) + call vex_copyi (code, INDEFI, Memi[buffer], nbuf) + call tbcpti (tptr, cptr, Memi[buffer], firstrow, lastrow) + call mfree (buffer, TY_INT) + case TY_REAL: + call malloc (buffer, nbuf, TY_REAL) + call vex_copyr (code, INDEFR, Memr[buffer], nbuf) + call tbcptr (tptr, cptr, Memr[buffer], firstrow, lastrow) + call mfree (buffer, TY_REAL) + case TY_DOUBLE: + call malloc (buffer, nbuf, TY_DOUBLE) + call vex_copyd (code, INDEFD, Memd[buffer], nbuf) + call tbcptd (tptr, cptr, Memd[buffer], firstrow, lastrow) + call mfree (buffer, TY_DOUBLE) + } + + firstrow = firstrow + MAXROWS + lastrow = lastrow + MAXROWS + } until (done) + + TED_DIRTY(tab) = YES + call vex_free (code) + } + + # Redraw screen if column is displayed + + if (col >= TED_LOCOL(scr) && col <= TED_HICOL(scr)) + call move_screen (scr, LEFT, YES) + + call sfree (sp) + +end + +# SUB_CMD -- Substitute strings in a single column + +procedure sub_cmd (scr, nargs, arglist) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +#-- +int col, irow, nrow, len +pointer sp, defcol, from, to, colstr, tab, cptr, tptr + +string nowrite "Cannot change read only table" +string numeric "Cannot change numeric column" + +bool substitute() +int tbpsta() + +begin + # Check for read only table + + tab = TED_TABLE(scr) + if (TED_READONLY(tab) == YES) { + call warn1_prompt (scr, nowrite) + return + } + + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (defcol, SZ_COLNAME, TY_CHAR) + call salloc (from, SZ_LINE, TY_CHAR) + call salloc (to, SZ_LINE, TY_CHAR) + + # Get name of column. Make sure it's a string column + + cptr = TED_COLPTR(tab, TED_CURCOL(scr)) + call tbcigt (cptr, TBL_COL_NAME, Memc[defcol], SZ_COLNAME) + + call getcol_cmd ("Column to change", 2, nargs, arglist, tab, + Memc[defcol], col) + + if (TED_COLTYPE(tab,col) > 0) { + call warn1_prompt (scr, numeric) + call sfree (sp) + return + } + + # Get target string + + call getstr_cmd ("Search string", 3, nargs, arglist, + Memc[from], SZ_LINE) + + if (Memc[from] == EOS) { + call sfree (sp) + return + } + + # Get replacement string + + call getstr_cmd ("Replacement string", 4, nargs, arglist, + Memc[to], SZ_LINE) + + # Allocate array to hold field + + len = - TED_COLTYPE(tab,col) + call salloc (colstr, len, TY_CHAR) + + # Get current number of rows in the table + + tptr = TED_TABPTR(tab) + cptr = TED_COLPTR(tab, col) + nrow = tbpsta (tptr ,TBL_NROWS) + + # Retrieve each field and perform substitution + + do irow = 1, nrow { + call tbegtt (tptr, cptr, irow, Memc[colstr], len) + + if (substitute (Memc[from], Memc[to], Memc[colstr], len)) { + TED_DIRTY(tab) = YES + call tbeptt (tptr, cptr, irow, Memc[colstr]) + } + } + + # Redraw screen if column is displayed + + if (col >= TED_LOCOL(scr) && col <= TED_HICOL(scr)) + call move_screen (scr, LEFT, YES) + + call sfree (sp) + +end + +# UPPER_CMD -- Convert a column to upper cse + +procedure upper_cmd (scr, nargs, arglist) + +pointer scr # i: Current screen descriptor +int nargs # i: Number of arguments +char arglist[ARB] # i: Argument list +#-- +extern strupr + +begin + # A common routine handle both the lower and upper case + # commands, since they are so similar + + call func_cmd (scr, nargs, arglist, strupr) +end + diff --git a/pkg/utilities/nttools/tedit/display/curses.h b/pkg/utilities/nttools/tedit/display/curses.h new file mode 100644 index 00000000..ea12d7f5 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses.h @@ -0,0 +1,86 @@ +# CURSES.H -- Macros used by the curses subroutines + +# Window which covers terminal screen + +define STDSCR 1 + +# The following string defines the set of commands read from the edcap file + +define CMDSTR "|MOVE_UP|MOVE_DOWN|MOVE_RIGHT|MOVE_LEFT|NEXT_WORD|PREV_WORD\ +|NEXT_PAGE|PREV_PAGE|MOVE_START|MOVE_END|MOVE_BOL|MOVE_EOL|DEL_CHAR|DEL_LEFT\ +|DEL_WORD|DEL_LINE|UNDEL_CHAR|UNDEL_WORD|UNDEL_LINE|GET_HELP|REPAINT\ +|EXIT_UPDATE|" + +# The following values are returned when +# the corresponding escape sequence is entered + +define K_BASE 256 # Smallest value + +define K_UP 256 # Move up one row +define K_DOWN 257 # Move down one row +define K_RIGHT 258 # Move right one column +define K_LEFT 259 # Move left one column +define K_NEXTW 260 # Move forwards one word +define K_PREVW 261 # Move backwards one word +define K_NEXTP 262 # Move forwards one window +define K_PREVP 263 # Move backwards one window +define K_HOME 264 # Move to first row +define K_END 265 # Move to last row +define K_BOL 266 # Move to first column in row +define K_EOL 267 # Move to last column in row +define K_DEL 268 # Delete character underneath cursor +define K_BS 269 # Delete character to left of cursor +define K_DWORD 270 # Delete previous word +define K_DLINE 271 # Delete entire line +define K_UNDCHR 272 # Undelete character +define K_UNDWRD 273 # Undelete word +define K_UNDLIN 274 # Undelete line +define K_HELP 275 # Display help window +define K_PAINT 276 # Force window redraw +define K_EXIT 277 # Exit procedure + +# Codes used by winstat to retrieve window fields + +define W_TOP 1 # Window's top row +define W_LEFT 2 # Window's leftmost column +define W_BOT 3 # Window's bottom row +define W_RIGHT 4 # Window's rightmost column +define W_CURROW 5 # Cursor row relative to window +define W_CURCOL 6 # Cursor column relative to window +define W_CLEAR 7 # Redraw window when refreshed +define W_LEAVE 8 # Leave cursor after redraw +define W_SCROLL 9 # Window will scroll +define W_HIDDEN 10 # Window is hidden +define W_BOXED 11 # Window is boxed +define W_ATRIB 12 # Character attribute of window + +# Direction to move rectangle used by ps_slide and wslide + +define DIR_UP 0 +define DIR_DOWN 1 +define DIR_LEFT 2 +define DIR_RIGHT 3 + +# Character attributes + +define A_NORM 0 +define A_STANDOUT 128 + +# Definition of rectangle + +define RSIZE 4 +define RTOP $1[1] +define RLEFT $1[2] +define RBOT $1[3] +define RRIGHT $1[4] + +# Macros used to manipulate rectangles + +define RWIDTH ($1[4] - $1[2] + 1) +define RHEIGHT ($1[3] - $1[1] + 1) +define RASG {$1[1] = $2; $1[2] = $3; $1[3] = $4; $1[4] = $5} +define RCPY {$1[1]=$2[1]; $1[2]=$2[2]; $1[3]=$2[3]; $1[4]=$2[4]} + +# Constant used to create a rectangle much greater than screen size + +define GIANT 9999 diff --git a/pkg/utilities/nttools/tedit/display/curses/README b/pkg/utilities/nttools/tedit/display/curses/README new file mode 100644 index 00000000..67220c91 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/README @@ -0,0 +1,387 @@ +The procedures in this directory are an implementation of the Unix +curses library, with a few deletions and extensions. The procedures +have been modified to work in an SPP environment instead of a C +environment. Unlike the C routines, they do not return an error status +as a function value. In fact, very few of the procedures call error, +instead they try to do the most reasonable thing. The mv macros are +not implemented, instead the program should call move() followed by +the appropriate procedure. Formatted reads and writes to windows are +not supported, all reading and writing is done using strings. +Subwindows are also not supported. The user program does not have +direct access to the window structure, the function winstat() is +provided to read fields from the structure. In order to make +customization of windows easier, each window can have an input +function and data structure bound to it. The functions bindstruct() +and getstruct() are provided for this purpose. The forms directory +gives several examples of binding functions and data structures to a +window. Two other procedures hidewin() and showwin() are provided to +hide a window which is currently displayed on the terminal and to +redisplay it. + +The procedure initscr() should be called before using any of the +procedures in the curses directory. It initializes the terminal and +creates the first window (referred to as STDSCR), which covers the +terminal scrren. The procedure endwin() should be called at the end of +the user program. It closes any windows which are still open and +resets the terminal. Windows are created by calling newwin() and +destroyed by calling delwin(). The terminal cursor is moved by the +procedure move(). Text is written into a window by the procedures +addch() and addstr(). Text is read from the keyboard and displayed in +the window by the procedures getch() and getstr(). Changes to the +window are not displayed until refresh() is called. Fuller +explanations of these and the other curses procedures is given below. + +Many procedures in this directory exist in two forms. The first form +uses the default window, STDSCR. This window is created when initscr() +is called and covers the entire screen. The second form uses any +window and has an extra argument to specify which window to use. The +names of the two forms are the same, except that the second has the +letter "w" as the first character. For example, addch() adds a +character to STDSCR, while waddch() adds a character to any window. +The macro STDSCR is defined in , so it can be used by your +program. Many of the procedures in this library operate relative to +the current cursor position in that window. To set the cursor +position, the program should call move() or wmove() first. Window +coordinates are passed row first, column second. The upper left corner +of a window is (1,1). + +procedure addch (ch) +procedure waddch (win, ch) + +pointer win # i: Window descriptor +char ch # i: Character to add + +This procedure adds a single character at the current cursor position. +The character currently at that position is overwritten. A linefeed +character clears the rest of the line and moves the cursor to the next +row. A tab character inserts the apropriate number of spaces at the +current position. A carriage return moves the cursor to the first +character on the current line. A backspace moves the cursor one column +left unless the cursor is in the first column of the window. + +procedure addstr (str) +procedure waddstr (win, str) + +int win # i: Window descriptor +char str[ARB] # i: String to add to window + +This procedure adds a string at the current cursor position. If part +of the string extends beyond the right edge of the window, it will be +truncated. Special characters have the same meaning as those in addch(). +The window will scroll if scrolling is enabled. + +procedure bindstruct (func, structure) +procedure wbindstruct (win, func, structure) + +int win # i: Window descriptor +extern func # i: Input function +pointer structure # i: Data structure + +This procedure binds an input function and a data structure to a +window. The data structure is used by the input function to maintain +the window's state. The input function is called by getch() and +getstr() to process keyboard input instead of the default procedure, +editfn(). The input function should have the following calling sequence. + +procedure func (win, str, maxch) + +int win # i: Window descriptor +char str[ARB] # io: String containing line +int maxch # i: Maximum line length + +When writing this procedure, the default procedure, editfn() should be +used as a guide. The procedure should update the terminal screen, +string, and data structure appropriately. When the procedure gets a +character indicating input is complete, the character should be pushed +back on the input stream with the procedure k_pushbk(). Then the +procedure should return the string to the calling program. The calling +program can also call getstruct() to retrieve the contents of the data +structure. + +procedure box (win, vert, hor) + +int win # i: Window descriptor +char vert # i: Character used for vertical side of window +char hor # i: Character used for horizontal side of window + +This procedure draws a box around a window. The box is inside the +original area of the window, which is then reduced so that subsequent +writes to the window will not overwrite the box. + +procedure clear () +procedure wclear (win) + +int win # i: Window descriptor + +This procedure clears a window. It is equivalent to calling clearok() +with flag set to true, followed by calling erase(). + +procedure clearok (win, flag) + +int win # i: Window descriptor +bool flag # i: Flag value + +This procedure sets the clear flag for a window. If the clear flag is +true, the entire window will be redrawn when refresh is called. + +procedure clrtobot () +procedure wclrtobot (win) + +int win # i: Window descriptor + +This procedure clears a window from the current cursor position to the +end of the window. + +procedure clrtoeol () +procedure wclrtoeol (win) + +int win # i: Window descriptor + +This procedure clears a window from the current cursor position to the +end of the line. + +procedure delch () +procedure wdelch (win) + +pointer win # i: Window descriptor + +This procedure deletes the character at the current cursor poisition +in the window. Subsequent characters on the line are moved to the left +by one. + +procedure deleteln () +procedure wdeleteln (win) + +pointer win # i: Window descriptor + +This procedure deletes the current line in the window. Subsequent +lines in the window slide up by one and the last line is left blank. + +procedure delwin (win) + +This procedure deletes a window created by newwin(). The terminal area +that was under the window before it was created is redisplayed. The +data structure associated with the window is freed, including the data +structure bound by bindstruct(). STDSCR cannot be deleted by this +procedure, it is deleted by endwin(). + +procedure echo () +procedure noecho () + +These procedures turn character echoing on and off. Character echoing +is on when the terminal is initialized. If character ecoing is off, +procedures addch() and addstr() will return immediately after being +called. + +procedure endwin () + +This procedure should be called at the end of a program which uses the +curses library. It deletes all windows that are still open (including +STDSCR) and resets the terminal. + +procedure erase () +procedure werase (win) + +int win # i: Window descriptor + +This procedure erases a window, filling it with blanks. + +int procedure getch () +int procedure wgetch (win) + +This procedure reads a single character from the keyboard and adds it +to the window at the current cursor position. If an input function +has been bound to the window by bindstruct(), the input procedure is +called to process the character. The procedure returns after calling +the input function once, regardless of the value of done. The returned +character is the first character in the string output by the input +function. + +procedure getstr (str, maxch) +procedure wgetstr (win, str, maxch) + +pointer win # i: Window descriptor +char str[ARB] # o: String that was read from the keyboard +int maxch # i: Maximum string length + +This procedure reads a string from the keyboard and displays it in the +window at the current cursor position. Editing keys are recognized; +however, editing is limited to a single line and keys which change the +current line cause the procedure to exit. The default behaviour of +this procedure can be modified by binding an input function to the +window with bindstruct(). + +procedure getstruct (structure) +procedure wgetstruct (win, structure) + +int win # i: Window descriptor +pointer structure # o: Data structure + +This procedure returns a pointer to the data structure that was bound +to the window by bindstruct(). + +procedure getyx (win, row, col) + +int win # i: Window descriptor +int row # o: Cursor row +int col # o: Cursor column + +This procedure returns the location of the cursor in a window. The +top left corner of a window is (1,1). + +procedure hidewin (win) + +int win # i: Window descriptor + +This procedure hides a window that is currently displayed on the +screen. The terminal area under the window is displayed after the +window is hidden. The window can be redisplayed by calling showwin(). + +char procedure inch () +char procedure winch (win) + +pointer win # i: Window descriptor + +This procedure returns the character at the current cursor location in +the window. + +procedure initscr () + +This procedure initializes the terminal and creates the default +window, STDSCR. It should be called before any other procedure in the +curses library is called. + +procedure insch (ch) +procedure winsch (win, ch) + +pointer win # i: Window descriptor +char ch # i: Character to insert + +This procedure inserts a character at the current cursor position. + +procedure insertln () +procedure winsertln (win) + +pointer win # i: Window descriptor + +This procedure inserts a blank line on the current row. The current +line and subsequent lines move down by one and the last line in the +window is deleted. + +procedure leaveok (win, flag) + +int win # i: Window descriptor +bool flag # i: Flag value + +This procedure sets the leave flag for a window. If the leave flag +is true, procedures that modify the screen will not move the terminal +cursor to the window's current cursor position when the window is +modified. If it is false, the terminal cursor position will be moved +when the window is updated. When a window is created, the leave flag +is set to false. + +procedure move (row, col) +procedure wmove (win, row, col) + +int win # i: Window descriptor +int row # i: Cursor row +int col # i: Cursor column + +This procedure moves the cursor position in a window. Coordinates are +relative to those of the window, and the top left corner of a window +has the coordinates (1,1) + +procedure mvwin (win, row, col) + +int win # i: Window descriptor +int row # i: New top row of window +int col # i: New left column of window + +This position moves the position of a window on the screen. The +position of a window is the position of the top left corner on the +terminal screen. If the new corrdinates would place part of the window +off the screen, the coordinates are modified so that the window stays +on the screen. + +int procedure newwin (nrows, ncols, row, col) + +int nrows # i: Window height +int ncols # i: Window width +int row # i: Top row of window +int col # i: Leftmost column of window + +This procedure creates a new window. The returned value is the window +descriptor, which is used as an argument to the other window +functions. The window position is relative to the top left corner of +the terminal, which has the coordinates (1,1). If part of the window +is off the terminal screen, it will be placed and sized so that the +entire window fits on the screen. + +procedure refresh () +procedure wrefresh (win) + +int win # i: Window descriptor + +This procedure causes all changes to a window that have been made by +other calls in this library to be displayed on the terminal screen. If +the clear flag has been set to yes by clearok(), the window will be +cleared and redrawn. + +procedure savewin () +procedure nosavewin () + +These procedures set and unset the save flag. If the save flag is set, +whenever a window is created, the area on the terminal screen under is +saved in a buffer so it can be restored when the window is hidden or +deleted. If a window will exist throughout the life of a program, the +save flag can be unset by calling nosavewin() before creating the +window so that the memory used to hold the buffer will not be wasted. +The save flag is initially set to yes so that all windows have +associated screen buffers by default. + +procedure scrollok (win, flag) + +int win # i: Window descriptor +bool flag # i: Flag value + +If the scroll flag is set to true, a window will scroll when an +attempt is made to write beyond the last line of a window. If the +scroll flag is false, the last line of the window will be overwritten. +When a new window is created, the scroll flag is set to false. + +procedure showwin (win) + +int win # i: Window descriptor + +This procedure shows a window that was previously hidden by a call to +hidewin(). If the window is not hidden, this procedure has no effect. + +procedure standout () +procedure standend () +procedure wstandout (win) +procedure wstandend (win) + +int win # i: Window descriptor + +These procedures modify the character attribute of a window. Calling +standout() causes all characters written to the window after the call +to be written in standout mode. Calling standend() causes all +characacters to be written in normal mode. When a window is created, +the character attribute of the window is normal. + +procedure wdimen (win, nrows, ncols) + +int win # i: Window descriptor +int nrows # o: Window height +int ncols # o: Window width + +This procedure returns the height and width of a window. + +int procedure winstat (win, what) + +int win # i: Window descriptor +int what # i: Field to retrieve + +This procedure returns a field from the window descriptor. The field +to retrieve is given by a symbolic constant. These constants are +listed in the include file . diff --git a/pkg/utilities/nttools/tedit/display/curses/addch.x b/pkg/utilities/nttools/tedit/display/curses/addch.x new file mode 100644 index 00000000..f08085e4 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/addch.x @@ -0,0 +1,30 @@ +include "../curses.h" + +# ADDCH -- Add a character to the standard screen +# +# B.Simon 01-Oct-90 Original + +procedure addch (ch) + +char ch # i: Character to add +#-- +char str[1] + +begin + str[1] = ch + str[2] = EOS + call waddstr (STDSCR, str) +end + +procedure waddch (win, ch) + +int win # i: Window descriptor +char ch # i: Character to add +#-- +char str[1] + +begin + str[1] = ch + str[2] = EOS + call waddstr (win, str) +end diff --git a/pkg/utilities/nttools/tedit/display/curses/addstr.x b/pkg/utilities/nttools/tedit/display/curses/addstr.x new file mode 100644 index 00000000..f675d151 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/addstr.x @@ -0,0 +1,157 @@ +include +include "../curses.h" +include "window.h" + +define TABSTOP 8 + +# ADDSTR -- Add a string to a window +# +# B.Simon 02-Oct-90 Original + +procedure addstr (str) + +char str[ARB] # i: String to add to window +#-- + +begin + call waddstr (STDSCR, str) +end + +procedure waddstr (win, str) + +int win # i: Window descriptor +char str[ARB] # i: String to add to window +#-- +include "window.com" + +bool moved +int row, col, nrows, ncols, ic, jc, mxchar, itab +pointer sp, line, pwin + +begin + pwin = warray[win] + + # Don't print anything if echoing is turned off + + if (echoed == NO) + return + + # Allocate an array to hold the string to print + + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Get the current cursor position and window size + + row = WIN_CURROW(pwin) + col = WIN_CURCOL(pwin) + ncols = WIN_WIDTH(pwin) + nrows = WIN_HEIGHT(pwin) + + ic = 0 + jc = 0 + moved = false + + repeat { + ic = ic + 1 + + # If the character is printable, just copy it to the array + # The array will be printed when the EOS is read + + if (IS_PRINT(str[ic])) { + col = col + 1 + Memc[line+jc] = str[ic] + jc = jc + 1 + + } else { + # Print any characters in the array before handling + # the non-printing character + + Memc[line+jc] = EOS + if (jc > 0) { + jc = 0 + + mxchar = ncols - WIN_CURCOL(pwin) + 1 + call ps_write (WIN_TOP(pwin)+WIN_CURROW(pwin)-1, + WIN_LEFT(pwin)+WIN_CURCOL(pwin)-1, + mxchar, Memc[line], WIN_ATRIB(pwin)) + + WIN_CURCOL(pwin) = col + WIN_CURROW(pwin) = row + + # Check for writing past the edge of the window + # and scrolling + + if (col > ncols) { + col = 1 + row = row + 1 + moved = true + + if (row > nrows) { + row = nrows + if (WIN_SCROLL(pwin) == YES) + call wslide (WIN_RECT(pwin), DIR_UP, 1) + } + } + } + + # Some non-printing characters require special action + # Others are mapped to printing characters and written + # to the array + + switch (str[ic]) { + case EOS: + ; + + case '\n': + call wclrtoeol (win) + col = 1 + row = row + 1 + moved = true + + # Scroll window if we've hit the last row + + if (row > nrows) { + row = nrows + if (WIN_SCROLL(pwin) == YES) + call wslide (WIN_RECT(pwin), DIR_UP, 1) + } + + case '\t': + do itab = 1, TABSTOP - mod (col, TABSTOP) { + Memc[line+jc] = ' ' + jc = jc + 1 + col = col + 1 + } + + case '\r': + if (col > 1) { + col = 1 + moved = true + } + + case '\010': + if (col > 1) { + col = col - 1 + moved = true + } + + default: + Memc[line+jc] = ' ' + col = col + 1 + jc = jc + 1 + } + } + + # Move cursor, as required + + if (moved) { + moved = false + call wmove (win, row, col) + } + + } until (str[ic] == EOS) + + call sfree (sp) + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/bindstruct.x b/pkg/utilities/nttools/tedit/display/curses/bindstruct.x new file mode 100644 index 00000000..f9502c3d --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/bindstruct.x @@ -0,0 +1,35 @@ +include "../curses.h" +include "window.h" + +# BINDSTRUCT -- Bind a data structure and function to a window + +procedure bindstruct (func, structure) + +extern func # i: Input function +pointer structure # i: Data structure +#-- + +begin + call wbindstruct (STDSCR, func, structure) +end + +procedure wbindstruct (win, func, structure) + +int win # i: Window descriptor +extern func # i: Input function +pointer structure # i: Data structure +#-- +include "window.com" + +pointer pwin +pointer locpr() + +begin + pwin = warray[win] + if (WIN_DATA(pwin) != NULL) + call mfree (WIN_DATA(pwin), TY_STRUCT) + + WIN_FUNC(pwin) = locpr (func) + WIN_DATA(pwin) = structure + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/box.x b/pkg/utilities/nttools/tedit/display/curses/box.x new file mode 100644 index 00000000..06eadbcd --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/box.x @@ -0,0 +1,56 @@ +include "../curses.h" +include "window.h" + +# BOX -- Draw a box around a window +# +# B.Simon 01-Oct-90 Original + +procedure box (win, vert, hor) + +int win # i: Window descriptor +char vert # i: Character used for vertical side of window +char hor # i: Character used for horizontal side of window +#-- +include "window.com" + +int vcode, hcode, rect[RSIZE] +pointer pwin + +begin + # Don't box window if either dimension < 3 or window is already boxed + + pwin = warray[win] + if (WIN_HEIGHT(pwin) < 3 || WIN_WIDTH(pwin) < 3 || + WIN_BOXED(pwin) == YES) + return + + # Draw box + + vcode = vert + hcode = hor + + RASG(rect, WIN_TOP(pwin), WIN_LEFT(pwin), + WIN_TOP(pwin), WIN_RIGHT(pwin)) + call ps_fill (rect, hcode, WIN_ATRIB(pwin)) + + RASG(rect, WIN_BOT(pwin), WIN_LEFT(pwin), + WIN_BOT(pwin), WIN_RIGHT(pwin)) + call ps_fill (rect, hcode, WIN_ATRIB(pwin)) + + RASG(rect, WIN_TOP(pwin), WIN_LEFT(pwin), + WIN_BOT(pwin), WIN_LEFT(pwin)) + call ps_fill (rect, vcode, WIN_ATRIB(pwin)) + + RASG(rect, WIN_TOP(pwin), WIN_RIGHT(pwin), + WIN_BOT(pwin), WIN_RIGHT(pwin)) + call ps_fill (rect, vcode, WIN_ATRIB(pwin)) + + # Reduce size of window's rectangle and mark as boxed + + WIN_TOP(pwin) = WIN_TOP(pwin) + 1 + WIN_LEFT(pwin) = WIN_LEFT(pwin) + 1 + WIN_BOT(pwin) = WIN_BOT(pwin) - 1 + WIN_RIGHT(pwin) = WIN_RIGHT(pwin) - 1 + WIN_BOXED(pwin) = YES + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/clear.x b/pkg/utilities/nttools/tedit/display/curses/clear.x new file mode 100644 index 00000000..7b69f63d --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/clear.x @@ -0,0 +1,35 @@ +include "../curses.h" +include "window.h" + +# CLEAR -- Clear window and force a redraw of the screen +# +# B.Simon 01-Oct-90 Original + +procedure clear () + +#-- +include "window.com" + +pointer pwin + +begin + pwin = warray[STDSCR] + WIN_CLEAR(pwin) = YES + + call werase (STDSCR) +end + +procedure wclear (win) + +int win # i: Window descriptor +#-- +include "window.com" + +pointer pwin + +begin + pwin = warray[win] + WIN_CLEAR(pwin) = YES + + call werase (win) +end diff --git a/pkg/utilities/nttools/tedit/display/curses/clearok.x b/pkg/utilities/nttools/tedit/display/curses/clearok.x new file mode 100644 index 00000000..9d3372a9 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/clearok.x @@ -0,0 +1,21 @@ +include "window.h" + +# CLEAROK -- Set the clear flag for a window +# +# B.Simon 01-Oct-90 Original + +procedure clearok (win, flag) + +int win # i: Window descriptor +bool flag # i: Flag value +#-- +include "window.com" + +pointer pwin +int btoi() + +begin + pwin = warray[win] + WIN_CLEAR(pwin) = btoi (flag) + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/clrtobot.x b/pkg/utilities/nttools/tedit/display/curses/clrtobot.x new file mode 100644 index 00000000..da60b805 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/clrtobot.x @@ -0,0 +1,56 @@ +include "../curses.h" +include "window.h" + +# CLRTOBOT -- Clear window to bottom +# +# B.Simon 28-Sep-90 Original + +procedure clrtobot () + +#-- + +begin + call wclrtobot (STDSCR) +end + +procedure wclrtobot (win) + +int win # i: Window descriptor +#-- +include "window.com" + +int blank, rect[RSIZE] +pointer pwin + +data blank / ' ' / + +begin + pwin = warray[win] + + # First line may be partial, so it must be handled separately + + if (WIN_CURCOL(pwin) == 1) { + RTOP(rect) = WIN_TOP(pwin) + WIN_CURROW(pwin) - 1 + } else { + RTOP(rect) = WIN_TOP(pwin) + WIN_CURROW(pwin) - 1 + RLEFT(rect) = WIN_LEFT(pwin) + WIN_CURCOL(pwin) - 1 + RBOT(rect) = RTOP(rect) + RRIGHT(rect) = WIN_RIGHT(pwin) + call ps_fill (rect, blank, WIN_ATRIB(pwin)) + + RTOP(rect) = min (RBOT(rect), RTOP(rect)+1) + } + + # Remaining lines form a rectangle + + RLEFT(rect) = WIN_LEFT(pwin) + RBOT(rect) = WIN_BOT(pwin) + RRIGHT(rect) = WIN_RIGHT(pwin) + + call ps_fill (rect, blank, WIN_ATRIB(pwin)) + if (WIN_LEAVE(pwin) == NO) { + call ps_setcur (WIN_TOP(pwin)+WIN_CURROW(pwin)-1, + WIN_LEFT(pwin)+WIN_CURCOL(pwin)-1) + } + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/clrtoeol.x b/pkg/utilities/nttools/tedit/display/curses/clrtoeol.x new file mode 100644 index 00000000..2c42a64e --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/clrtoeol.x @@ -0,0 +1,45 @@ +include "../curses.h" +include "window.h" + +# CLRTOEOL -- Clear window to end of current line +# +# B.Simon 01-Oct-90 Original + +procedure clrtoeol () + +#-- + +begin + call wclrtoeol (STDSCR) +end + +procedure wclrtoeol (win) + +int win # i: Window descriptor +#-- +include "window.com" + +int blank, rect[RSIZE] +pointer pwin + +data blank / ' ' / + +begin + pwin = warray[win] + + # Construct the rectangle consisting of the remainder of the + # current line and fill with blanks + + RTOP(rect) = WIN_TOP(pwin) + WIN_CURROW(pwin) - 1 + RLEFT(rect) = WIN_LEFT(pwin) + WIN_CURCOL(pwin) - 1 + RBOT(rect) = RTOP(rect) + RRIGHT(rect) = WIN_RIGHT(pwin) + call ps_fill (rect, blank, WIN_ATRIB(pwin)) + + # Move the cursor to the new end of the line + + if (WIN_LEAVE(pwin) == NO) + call ps_setcur (WIN_TOP(pwin)+WIN_CURROW(pwin)-1, + WIN_LEFT(pwin)+WIN_CURCOL(pwin)-1) + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/delch.x b/pkg/utilities/nttools/tedit/display/curses/delch.x new file mode 100644 index 00000000..a58ed17d --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/delch.x @@ -0,0 +1,41 @@ +include "../curses.h" +include "window.h" + +# DELCH -- Delete a character from the window + +procedure delch () + +# B.Simon 01-Oct-90 Original + +#-- + +begin + call wdelch (STDSCR) +end + +procedure wdelch (win) + +pointer win # i: Window descriptor +#-- +include "window.com" + +int rect[RSIZE] +pointer pwin + +begin + pwin = warray[win] + + # Construct rectangle to slide + + RTOP(rect) = WIN_TOP(pwin) + WIN_CURROW(pwin) - 1 + RLEFT(rect) = WIN_LEFT(pwin) + WIN_CURCOL(pwin) + RBOT(rect) = RTOP(rect) + RRIGHT(rect) = WIN_RIGHT(pwin) + + call wslide (rect, DIR_LEFT, 1) + + if (WIN_LEAVE(pwin) == NO) + call ps_setcur (WIN_TOP(pwin)+WIN_CURROW(pwin)-1, + WIN_LEFT(pwin)+WIN_CURCOL(pwin)-1) + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/deleteln.x b/pkg/utilities/nttools/tedit/display/curses/deleteln.x new file mode 100644 index 00000000..f5afa1dd --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/deleteln.x @@ -0,0 +1,41 @@ +include "../curses.h" +include "window.h" + +# DELETELN -- Delete a line from the window +# +# B.Simon 01-Oct-90 Original + +procedure deleteln () + +#-- + +begin + call wdeleteln (STDSCR) +end + +procedure wdeleteln (win) + +pointer win # i: Window descriptor +#-- +include "window.com" + +int rect[RSIZE] +pointer pwin + +begin + pwin = warray[win] + + # Construct rectangle to slide + + RTOP(rect) = WIN_TOP(pwin) + WIN_CURROW(pwin) - 1 + RLEFT(rect) = WIN_LEFT(pwin) + RBOT(rect) = WIN_BOT(pwin) + RRIGHT(rect) = WIN_RIGHT(pwin) + + call wslide (rect, DIR_UP, 1) + + if (WIN_LEAVE(pwin) == NO) + call ps_setcur (WIN_TOP(pwin)+WIN_CURROW(pwin)-1, + WIN_LEFT(pwin)+WIN_CURCOL(pwin)-1) + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/delwin.x b/pkg/utilities/nttools/tedit/display/curses/delwin.x new file mode 100644 index 00000000..5b0db192 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/delwin.x @@ -0,0 +1,42 @@ +include "../curses.h" +include "window.h" + +# DELWIN --Delete a window +# +# B.Simon 28-Sep-90 Original + +procedure delwin (win) + +int win # i: Window descriptor +#-- +include "window.com" + +int rect[RSIZE] +pointer pwin + +begin + # Can't free the standard screen + + if (win == STDSCR) + return + + pwin = warray[win] + + # Copy the screen under the window back to the terminal + # and then free the buffer which held it + + if (WIN_BUFFER(pwin) != NULL) { + call wrect (win, YES, rect) + call putscreen (rect, WIN_BUFFER(pwin)) + call freescreen (WIN_BUFFER(pwin)) + } + + # Free any data structure associated with the window + + if (WIN_DATA(pwin) != NULL) + call mfree (WIN_DATA(pwin), TY_STRUCT) + + call mfree (pwin, TY_STRUCT) + warray[win] = NULL + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/echo.x b/pkg/utilities/nttools/tedit/display/curses/echo.x new file mode 100644 index 00000000..8152aff6 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/echo.x @@ -0,0 +1,23 @@ +include "window.h" + +# ECHO -- Turn character echoing on +# +# B.Simon 02-Oct-90 Original + +procedure echo () + +#-- +include "window.com" + +begin + echoed = YES +end + +procedure noecho () + +#-- +include "window.com" + +begin + echoed = NO +end diff --git a/pkg/utilities/nttools/tedit/display/curses/endwin.x b/pkg/utilities/nttools/tedit/display/curses/endwin.x new file mode 100644 index 00000000..87a6c826 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/endwin.x @@ -0,0 +1,34 @@ +include "window.h" + +# ENDWIN -- Finish up window routines +# +# B.Simon 28-Sep-90 Original + +procedure endwin () + +#-- +include "window.com" + +int win +pointer pwin + +begin + # Release windows that are still active + + do win = 1, MAXWIN { + pwin = warray[win] + if (pwin != NULL) { + if (WIN_BUFFER(pwin) != NULL) + call freescreen (WIN_BUFFER(pwin)) + if (WIN_DATA(pwin) != NULL) + call mfree (WIN_DATA(pwin), TY_STRUCT) + call mfree (pwin, TY_STRUCT) + } + } + + # Reset terminal + + call k_end + call ps_end + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/erase.x b/pkg/utilities/nttools/tedit/display/curses/erase.x new file mode 100644 index 00000000..86b529a8 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/erase.x @@ -0,0 +1,37 @@ +include "../curses.h" +include "window.h" + +# ERASE -- Erase window +# +# B.Simon 28-Sep-90 Original + +procedure erase () + +#-- + +begin + call werase (STDSCR) +end + +procedure werase (win) + +int win # i: Window descriptor +#-- +include "window.com" + +int blank +pointer pwin + +data blank / ' ' / + +begin + pwin = warray[win] + call ps_fill (WIN_RECT(pwin), blank, WIN_ATRIB(pwin)) + + if (WIN_LEAVE(pwin) == NO) { + call ps_setcur (WIN_TOP(pwin), WIN_LEFT(pwin)) + WIN_CURROW(pwin) = 1 + WIN_CURCOL(pwin) = 1 + } + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/freescreen.x b/pkg/utilities/nttools/tedit/display/curses/freescreen.x new file mode 100644 index 00000000..66321451 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/freescreen.x @@ -0,0 +1,13 @@ +# FREESCREEN -- Free a window's buffer +# +# B.Simon 26-Sep-90 Original + +procedure freescreen (buffer) + +pointer buffer # i: Buffer allocated by wgetscr +#-- + +begin + if (buffer != NULL) + call mfree (buffer, TY_CHAR) +end diff --git a/pkg/utilities/nttools/tedit/display/curses/getch.x b/pkg/utilities/nttools/tedit/display/curses/getch.x new file mode 100644 index 00000000..9d69c11f --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/getch.x @@ -0,0 +1,53 @@ +include "../curses.h" +include "window.h" + +# GETCH -- Get a character and display it in the window + +int procedure getch () + +# B.Simon 01-Oct-90 Original + +#-- +int wgetch() + +begin + return (wgetch (STDSCR)) +end + +int procedure wgetch (win) + +pointer win # i: Window descriptor +#-- +include "window.com" + +char str[1] +int ch +pointer pwin + +int k_get() + +begin + str[1] = EOS + str[2] = EOS + pwin = warray[win] + + if (WIN_FUNC(pwin) == NULL) { + call ps_synch + ch = k_get () + + if (ch < K_BASE) { + str[1] = ch + call waddstr (win, str) + } + + } else { + call zcall3 (WIN_FUNC(pwin), win, str, 1) + if (str[1] == EOS) { + ch = k_get () # get pushed back character + } else { + ch = str[1] + } + } + + return (ch) +end diff --git a/pkg/utilities/nttools/tedit/display/curses/getscreen.x b/pkg/utilities/nttools/tedit/display/curses/getscreen.x new file mode 100644 index 00000000..58020c3f --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/getscreen.x @@ -0,0 +1,48 @@ +include "../curses.h" + +# GETSCREEN -- Retrieve screen contents into a window's buffer +# +# B.Simon 26-Sep-90 Original + +procedure getscreen (source, buffer) + +int source[RSIZE] # i: Rectangle to be retrieved +pointer buffer # o: Buffer (allocated by this routine) +#-- + +int dest[RSIZE] +int maxcol, maxrow, ncols, nrows, irow +pointer buf, scr + +bool ps_intersect() +int ps_width(), ps_height() +pointer ps_screen() + +begin + # Clip the rectangle to the screen boundary + # If the rectangle is entirely off the screen, return + + buffer = NULL + maxcol = ps_width () + maxrow = ps_height () + if (! ps_intersect (source, maxrow, maxcol, dest)) + return + + # Allocate buffer to hold screen contents + + ncols = RWIDTH(dest) + nrows = RHEIGHT(dest) + call malloc (buffer, ncols*nrows, TY_CHAR) + + # Copy screen contents to buffer + + buf = buffer + scr = ps_screen (RTOP(dest), RLEFT(dest)) + + do irow = RTOP(dest), RBOT(dest) { + call amovc (Memc[scr], Memc[buf], ncols) + scr = scr + maxcol + buf = buf + ncols + } + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/getstr.x b/pkg/utilities/nttools/tedit/display/curses/getstr.x new file mode 100644 index 00000000..6c1d38e6 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/getstr.x @@ -0,0 +1,317 @@ +include +include "../curses.h" +include "window.h" + +# GETSTR -- Get a string from the keyboard and display it in the window +# +# B.Simon 12-Dec-90 Original +# B.Simon 21-Mar-91 Add several new commands + +procedure getstr (str, maxch) + +char str[ARB] # o: String that was read from the keyboard +int maxch # i: Maximum string length +#-- +int ch + +int k_get() + +begin + str[1] = EOS + call weditstr (STDSCR, str, maxch) + + ch = k_get () # discard pushed back character +end + +procedure wgetstr (win, str, maxch) + +pointer win # i: Window descriptor +char str[ARB] # o: String that was read from the keyboard +int maxch # i: Maximum string length +#-- +int ch + +int k_get() + +begin + str[1] = EOS + call weditstr (win, str, maxch) + + ch = k_get () # discard pushed back character +end + +# EDITSTR -- Edit a string while displaying it in the window + +procedure editstr (str, maxch) + +char str[ARB] # u: String to edit +int maxch # i: Maximum string length +#-- + +begin + call weditstr (STDSCR, str, maxch) +end + +procedure weditstr (win, str, maxch) + +pointer win # i: Window descriptor +char str[ARB] # u: String to edit +int maxch # i: Maximum string length +#-- +include "window.com" + +pointer pwin + +begin + # NOTE: It is the reponsibility of the calling program + # to make sure that the current window contents and the + # string passed to this procedure are in agreement before + # this procedure is called. + + pwin = warray[win] + + if (WIN_FUNC(pwin) == NULL) { + call editfn (win, str, maxch) + } else { + call zcall3 (WIN_FUNC(pwin), win, str, maxch) + } + +end + +# EDITFN -- Default function to process window input + +procedure editfn (win, str, maxch) + +int win # i: Window descriptor +char str[ARB] # u: String containing line +int maxch # i: Maximum line length +#-- +int row, col, ch, ic, jc, mc, nc +pointer sp, buffer + +int strlen(), k_get(), winstat() + +begin + ic = 0 + nc = strlen (str) + + row = winstat (win, W_CURROW) + col = winstat (win, W_CURCOL) + + call smark (sp) + call salloc (buffer, SZ_LINE, TY_CHAR) + Memc[buffer] = EOS + + while (nc < maxch) { + + # Read character from keyboard + + call ps_synch + ch = k_get () + + # Check for carriage return + + if (ch == '\r') + break + + if (IS_PRINT(ch)) { + ic = ic + 1 + nc = nc + 1 + + if (ic == nc) { + str[ic] = ch + str[ic+1] = EOS + call waddstr (win, str[ic]) + + } else { + call amovc (str[ic], str[ic+1], nc-ic+1) + + str[ic] = ch + call winsch (win, str[ic]) + } + + } else { + switch (ch) { + case K_UP: # Move up one field + break + + case K_DOWN: # Move down one field + break + + case K_RIGHT: # Move right one column + if (ic < nc) { + ic = ic + 1 + call wmove (win, row, col+ic) + } + + case K_LEFT: # Move left one column + if (ic > 0) { + ic = ic - 1 + call wmove (win, row, col+ic) + } + + case K_NEXTW: # Move forwards one word + call mvword_next (str, ic, jc) + + if (jc > ic) { + ic = jc + call wmove (win, row, col+ic) + } + + case K_PREVW: # Move backwards one word + call mvword_prev (str, ic, jc) + + if (jc < ic) { + ic = jc + call wmove (win, row, col+ic) + } + + case K_NEXTP: # Move forwards one screen + break + + case K_PREVP: # Move backwards one screen + break + + case K_HOME: # Move to first field + break + + case K_END: # Move to last field + break + + case K_BOL: # Move to first column in line + if (ic > 0) { + ic = 0 + call wmove (win, row, col) + } + + case K_EOL: # Move to last column in line + if (ic < nc) { + ic = nc + call wmove (win, row, col+ic) + } + + case K_DEL: # Delete character underneath cursor + if (ic < nc) { + mc = strlen (Memc[buffer]) + + Memc[buffer+mc] = str[ic+1] + Memc[buffer+mc+1] = EOS + + call amovc (str[ic+2], str[ic+1], nc-ic) + + call wdelch (win) + nc = nc - 1 + } + + case K_BS: # Delete character to left of cursor + if (ic > 0) { + mc = strlen (Memc[buffer]) + + call amovc (Memc[buffer], Memc[buffer+1], mc+1) + Memc[buffer] = str[ic] + + ic = ic - 1 + call amovc (str[ic+2], str[ic+1], nc-ic) + + call wmove (win, row, col+ic) + call wdelch (win) + nc = nc - 1 + } + + case K_DWORD: # Delete next word + call mvword_next (str, ic, jc) + + if (jc > ic) { + mc = strlen (Memc[buffer]) + call strcpy (str[ic+1], Memc[buffer+mc], jc-ic) + call amovc (str[jc+1], str[ic+1], nc-jc+1) + + call wclrtoeol (win) + call waddstr (win, str[ic+1]) + call wmove (win, row, col+ic) + nc = nc - (jc - ic) + } + + case K_DLINE: # Delete entire line + if (nc > 0) { + call strcpy (str[ic+1], Memc[buffer], nc-ic) + str[ic+1] = EOS + + call wclrtoeol (win) + nc = ic + } + + case K_UNDCHR: # Undelete a character + mc = strlen (Memc[buffer]) + if (mc > 0) { + call amovc (str[ic+1], str[ic+2], nc-ic+1) + str[ic+1] = Memc[buffer+mc-1] + + Memc[buffer+mc-1] = EOS + call winsch (win, str[ic+1]) + + ic = ic + 1 + nc = nc + 1 + } + + case K_UNDWRD: # Undelete a word + mc = strlen (Memc[buffer]) + call mvword_prev (Memc[buffer], mc, jc) + + mc = mc - jc + if (mc > 0) { + call amovc (str[ic+1], str[ic+mc+1], nc-ic+1) + call amovc (Memc[buffer+jc], str[ic+1], mc) + + Memc[buffer+jc] = EOS + call wclrtoeol (win) + call waddstr (win, str[ic+1]) + + ic = ic + mc + nc = nc + mc + call wmove (win, row, col+ic) + } + + case K_UNDLIN: # Undelete a line + mc = strlen (Memc[buffer]) + if (mc > 0) { + call amovc (str[ic+1], str[ic+mc+1], nc-ic+1) + call amovc (Memc[buffer], str[ic+1], mc) + + Memc[buffer] = EOS + call wclrtoeol (win) + call waddstr (win, str[ic+1]) + + ic = ic + mc + nc = nc + mc + call wmove (win, row, col+ic) + } + + case K_HELP: # Display help screen + break + + case K_PAINT: # Redraw the screen + call clearok (STDSCR, true) + call wrefresh (STDSCR) + call wmove (win, row, col+ic) + + case K_EXIT: # Exit procedure + break + + default: # Any other character + break + } + } + } + + # Terminate string with EOS and push back character + # that terminated input + + if (nc >= maxch) + ch = EOS + + str[nc+1] = EOS + call k_pushbk (ch) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tedit/display/curses/getstruct.x b/pkg/utilities/nttools/tedit/display/curses/getstruct.x new file mode 100644 index 00000000..9fbce77e --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/getstruct.x @@ -0,0 +1,27 @@ +include "../curses.h" +include "window.h" + +# GETSTRUCT -- Get the data structure associated with a window + +procedure getstruct (structure) + +pointer structure # o: Data structure +#-- + +begin + call wgetstruct (STDSCR, structure) +end + +procedure wgetstruct (win, structure) + +int win # i: Window descriptor +pointer structure # o: Data structure +#-- +include "window.com" + +pointer pwin + +begin + pwin = warray[win] + structure = WIN_DATA(pwin) +end diff --git a/pkg/utilities/nttools/tedit/display/curses/getyx.x b/pkg/utilities/nttools/tedit/display/curses/getyx.x new file mode 100644 index 00000000..d25b9b46 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/getyx.x @@ -0,0 +1,22 @@ +include "window.h" + +# GETYX -- Get the current cursor position +# +# B.Simon 02-Oct-90 Original + +procedure getyx (win, row, col) + +int win # i: Window descriptor +int row # o: Cursor row +int col # o: Cursor column +#-- +include "window.com" + +pointer pwin + +begin + pwin = warray[win] + + row = WIN_CURROW(pwin) + col = WIN_CURCOL(pwin) +end diff --git a/pkg/utilities/nttools/tedit/display/curses/hidewin.x b/pkg/utilities/nttools/tedit/display/curses/hidewin.x new file mode 100644 index 00000000..f116cffd --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/hidewin.x @@ -0,0 +1,40 @@ +include "../curses.h" +include "window.h" + +# HIDEWIN -- Hide a window +# +# B.Simon 28-Sep-90 Original + +procedure hidewin (win) + +int win # i: Window descriptor +#-- +include "window.com" + +int rect[RSIZE] +pointer pwin, buffer + +begin + pwin = warray[win] + + # Don't do anything if the screen under the window wasn't + # saved or the window is already hidden + + if (WIN_BUFFER(pwin) == NULL || WIN_HIDDEN(pwin) == YES) + return + + # Save the current window contents in a buffer, + # and restore the screen under the window + + call wrect (win, YES, rect) + call getscreen (rect, buffer) + call putscreen (rect, WIN_BUFFER(pwin)) + + # Place the window contents in its own buffer and + # mark the window as hidden + + call freescreen (WIN_BUFFER(pwin)) + WIN_BUFFER(pwin) = buffer + WIN_HIDDEN(pwin) = YES + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/inch.x b/pkg/utilities/nttools/tedit/display/curses/inch.x new file mode 100644 index 00000000..9d80df3b --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/inch.x @@ -0,0 +1,49 @@ +include "../curses.h" +include "window.h" + +# INCH -- Get character at current cursor position +# +# B.Simon 02-Oct-90 Original + +char procedure inch () + +#-- +char winch() + +begin + return (winch (STDSCR)) +end + +char procedure winch (win) + +pointer win # i: Window descriptor +#-- +include "window.com" + +char ch +int rect[RSIZE] +pointer pwin, buf + +begin + pwin = warray[win] + + # Create a box containing the character + + if (WIN_BOXED(pwin) == NO) { + RTOP(rect) = WIN_TOP(pwin) + WIN_CURROW(pwin) - 1 + RLEFT(rect) = WIN_LEFT(pwin) + WIN_CURCOL(pwin) - 1 + } else { + RTOP(rect) = WIN_TOP(pwin) + WIN_CURROW(pwin) + RLEFT(rect) = WIN_LEFT(pwin) + WIN_CURCOL(pwin) + } + RBOT(rect) = RTOP(rect) + RRIGHT(rect) = RLEFT(rect) + + # Get the character under the cursor + + call getscreen (rect, buf) + ch = Memc[buf] + call freescreen (buf) + + return (ch) +end diff --git a/pkg/utilities/nttools/tedit/display/curses/initscr.x b/pkg/utilities/nttools/tedit/display/curses/initscr.x new file mode 100644 index 00000000..caa6b9fb --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/initscr.x @@ -0,0 +1,33 @@ +include "../curses.h" +include "window.h" + +# INITSCR -- Initialize curses routines + +procedure initscr () + +#-- +include "window.com" + +int stdscr +string cmdlist CMDSTR + +int newwin() + +begin + # Initialize global variables + + saved = NO + echoed = YES + call aclri (warray, MAXWIN) + + # Initialize terminal + + call ps_begin + call k_begin (cmdlist) + + # Create standard screen (STDSCR) + + stdscr = newwin (GIANT, GIANT, 1, 1) + saved = YES + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/insch.x b/pkg/utilities/nttools/tedit/display/curses/insch.x new file mode 100644 index 00000000..67dc9a7b --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/insch.x @@ -0,0 +1,51 @@ +include "../curses.h" +include "window.h" + +# INSCH -- Insert a character in the window +# +# B.Simon 02-Oct-90 Original + +procedure insch (ch) + +char ch # i: Character to insert +#-- + +begin + call winsch (STDSCR, ch) +end + +procedure winsch (win, ch) + +pointer win # i: Window descriptor +char ch # i: Character to insert +#-- +include "window.com" + +char str[1] +int rect[RSIZE] +pointer pwin + +begin + + pwin = warray[win] + + # Construct rectangle to slide + + RTOP(rect) = WIN_TOP(pwin) + WIN_CURROW(pwin) - 1 + RLEFT(rect) = WIN_LEFT(pwin) + WIN_CURCOL(pwin) - 1 + RBOT(rect) = RTOP(rect) + RRIGHT(rect) = WIN_RIGHT(pwin) + + # Slide rectangle + + call wslide (rect, DIR_RIGHT, 1) + call ps_setcur (WIN_TOP(pwin)+WIN_CURROW(pwin)-1, + WIN_LEFT(pwin)+WIN_CURCOL(pwin)-1) + + # Write new character + + str[1] = ch + str[2] = EOS + call waddstr (win, str) + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/insertln.x b/pkg/utilities/nttools/tedit/display/curses/insertln.x new file mode 100644 index 00000000..604d860d --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/insertln.x @@ -0,0 +1,41 @@ +include "../curses.h" +include "window.h" + +# INSERTLN -- Insert a blank line in the window +# +# B.Simon 02-Oct-90 Original + +procedure insertln () + +#-- + +begin + call winsertln (STDSCR) +end + +procedure winsertln (win) + +pointer win # i: Window descriptor +#-- +include "window.com" + +int rect[RSIZE] +pointer pwin + +begin + pwin = warray[win] + + # Construct rectangle to slide + + RTOP(rect) = WIN_TOP(pwin) + WIN_CURROW(pwin) - 1 + RLEFT(rect) = WIN_LEFT(pwin) + RBOT(rect) = WIN_BOT(pwin) + RRIGHT(rect) = WIN_RIGHT(pwin) + + call wslide (rect, DIR_DOWN, 1) + + if (WIN_LEAVE(pwin) == NO) + call ps_setcur (WIN_TOP(pwin)+WIN_CURROW(pwin)-1, + WIN_LEFT(pwin)+WIN_CURCOL(pwin)-1) + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/leaveok.x b/pkg/utilities/nttools/tedit/display/curses/leaveok.x new file mode 100644 index 00000000..3ce0f208 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/leaveok.x @@ -0,0 +1,21 @@ +include "window.h" + +# LEAVEOK -- Set the leave flag for a window +# +# B.Simon 02-Oct-90 Original + +procedure leaveok (win, flag) + +int win # i: Window descriptor +bool flag # i: Flag value +#-- +include "window.com" + +pointer pwin +int btoi() + +begin + pwin = warray[win] + WIN_LEAVE(pwin) = btoi (flag) + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/mkpkg b/pkg/utilities/nttools/tedit/display/curses/mkpkg new file mode 100644 index 00000000..7708de04 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/mkpkg @@ -0,0 +1,49 @@ +# Update the display library. +# Author: B.Simon 01-APR-91 + +$checkout libpkg.a ../../ +$update libpkg.a +$checkin libpkg.a ../../ +$exit + +libpkg.a: + addch.x "../curses.h" + addstr.x "../curses.h" "window.h" "window.com" + bindstruct.x "../curses.h" "window.h" "window.com" + box.x "../curses.h" "window.h" "window.com" + clear.x "../curses.h" "window.h" "window.com" + clearok.x "window.h" "window.com" + clrtobot.x "../curses.h" "window.h" "window.com" + clrtoeol.x "../curses.h" "window.h" "window.com" + delch.x "../curses.h" "window.h" "window.com" + deleteln.x "../curses.h" "window.h" "window.com" + delwin.x "../curses.h" "window.h" "window.com" + echo.x "window.h" "window.com" + endwin.x "window.h" "window.com" + erase.x "../curses.h" "window.h" "window.com" + freescreen.x + getch.x "../curses.h" "window.h" "window.com" + getscreen.x "../curses.h" + getstr.x "../curses.h" "window.h" "window.com" + getstruct.x "../curses.h" "window.h" "window.com" + getyx.x "window.h" "window.com" + hidewin.x "../curses.h" "window.h" "window.com" + inch.x "../curses.h" "window.h" "window.com" + initscr.x "../curses.h" "window.h" "window.com" + insch.x "../curses.h" "window.h" "window.com" + insertln.x "../curses.h" "window.h" "window.com" + leaveok.x "window.h" "window.com" + move.x "../curses.h" "window.h" "window.com" + mvwin.x "../curses.h" "window.h" "window.com" + mvword.x + newwin.x "../curses.h" "window.h" "window.com" + putscreen.x "../curses.h" + refresh.x "../curses.h" "window.h" "window.com" + savewin.x "window.h" "window.com" + scrollok.x "window.h" "window.com" + showwin.x "../curses.h" "window.h" "window.com" + standout.x "../curses.h" "window.h" "window.com" + wdimen.x "../curses.h" "window.h" "window.com" + winstat.x "../curses.h" "window.h" "window.com" + wslide.x "../curses.h" + ; diff --git a/pkg/utilities/nttools/tedit/display/curses/move.x b/pkg/utilities/nttools/tedit/display/curses/move.x new file mode 100644 index 00000000..ba3725f7 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/move.x @@ -0,0 +1,39 @@ +include "../curses.h" +include "window.h" + +# MOVE -- Move the cursor coordinates +# +# B.Simon 02-Oct-90 Original + +procedure move (row, col) + +int row # i: Cursor row +int col # i: Cursor column +#-- + +begin + call wmove (STDSCR, row, col) +end + +procedure wmove (win, row, col) + +int win # i: Window descriptor +int row # i: Cursor row +int col # i: Cursor column +#-- +include "window.com" + +pointer pwin + +begin + pwin = warray[win] + + WIN_CURROW(pwin) = max (1, row) + WIN_CURROW(pwin) = min (WIN_CURROW(pwin), WIN_HEIGHT(pwin)) + + WIN_CURCOL(pwin) = max (1, col) + WIN_CURCOL(pwin) = min (WIN_CURCOL(pwin), WIN_WIDTH(pwin)) + + call ps_setcur (WIN_TOP(pwin)+WIN_CURROW(pwin)-1, + WIN_LEFT(pwin)+WIN_CURCOL(pwin)-1) +end diff --git a/pkg/utilities/nttools/tedit/display/curses/mvwin.x b/pkg/utilities/nttools/tedit/display/curses/mvwin.x new file mode 100644 index 00000000..dd7b9d73 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/mvwin.x @@ -0,0 +1,63 @@ +include "../curses.h" +include "window.h" + +# MVWIN -- Move home position of a window +# +# B.Simon 28-Sep-90 Original + +procedure mvwin (win, row, col) + +int win # i: Window descriptor +int row # i: New top row of window +int col # i: New left column of window +#-- +include "window.com" + +bool shown +int rect[RSIZE] +int maxrow, maxcol, drow, dcol +pointer pwin + +int ps_width(), ps_height() + +begin + pwin = warray[win] + + # Compute new rectangle containing window + # Make sure it is confined to the current screen + + maxrow = ps_height () + maxcol = ps_width () + + drow = WIN_HEIGHT(pwin) - 1 + dcol = WIN_WIDTH(pwin) - 1 + + RTOP(rect) = max (1, row) + if (RTOP(rect) + drow > maxrow) + RTOP(rect) = maxrow - drow + + RLEFT(rect) = max (1, col) + if (RLEFT(rect) + dcol > maxcol) + RLEFT(rect) = maxcol - dcol + + RBOT(rect) = RTOP(rect) + drow + RRIGHT(rect) = RLEFT(rect) + dcol + + # Move the window by hiding it at its old location + # and showing it at the new location + + if (RTOP(rect) != WIN_TOP(pwin) || RLEFT(rect) != WIN_LEFT(pwin)) { + shown = WIN_HIDDEN(pwin) == NO + if (shown) + call hidewin (win) + + WIN_TOP(pwin) = RTOP(rect) + WIN_LEFT(pwin) = RLEFT(rect) + WIN_BOT(pwin) = RBOT(rect) + WIN_RIGHT(pwin) = RRIGHT(rect) + + if (shown) + call showwin (win) + } + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/mvword.x b/pkg/utilities/nttools/tedit/display/curses/mvword.x new file mode 100644 index 00000000..6a606e0d --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/mvword.x @@ -0,0 +1,56 @@ +# MVWORD -- Move one word over in a string +# +# B.Simon 20-Mar-91 Original + +procedure mvword_next (str, ic, jc) + +char str[ARB] # i: String containing words +int ic # i: Starting character (0 to strlen(str)) +int jc # o: Character before start of next word +#-- +int nc +int strlen() + +begin + # Find next blank + + nc = strlen (str) + for (jc = min (ic+1, nc); jc < nc; jc = jc + 1) { + if (str[jc] <= ' ') + break + } + + # Find first non-blank character after blank + + for ( ; jc < nc; jc = jc + 1) { + if (str[jc] > ' ') { + jc = jc - 1 # back up to previous blank + break + } + } + +end + +procedure mvword_prev (str, ic, jc) + +char str[ARB] # i: String containing words +int ic # i: Starting character (0 to strlen(str)) +int jc # o: Character before start of next word +#-- + +begin + # Find previous nonblank character + + for (jc = max (ic-1, 0); jc > 0; jc = jc - 1) { + if (str[jc] > ' ') + break + } + + # Find blank preceding non-blank character + + for ( ; jc > 0; jc = jc - 1) { + if (str[jc] <= ' ') + break + } + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/newwin.x b/pkg/utilities/nttools/tedit/display/curses/newwin.x new file mode 100644 index 00000000..f2195309 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/newwin.x @@ -0,0 +1,83 @@ +include "../curses.h" +include "window.h" + +# NEWWIN -- Create a new window +# +# B.Simon 28-Sep-90 Original + +int procedure newwin (nrows, ncols, row, col) + +int nrows # i: Window height +int ncols # i: Window width +int row # i: Top row of window +int col # i: Leftmost column of window +#-- +include "window.com" + +int win, maxrow, maxcol +pointer pwin + +int ps_height(), ps_width() + +begin + # Find an empty slot in the window array and allocate a window + + for (win = 1; win <= MAXWIN; win = win + 1) { + if (warray[win] == NULL) + break + } + + if (win > MAXWIN) + call error (1, "Cannot create window") + + call malloc (pwin, LEN_WINSTRUCT, TY_STRUCT) + warray[win] = pwin + + # Compute the window's rectangle, making sure it is on the screen + + maxrow = ps_height () + maxcol = ps_width () + + if (row + nrows - 1 > maxrow) + WIN_TOP(pwin) = maxrow - nrows + 1 + else + WIN_TOP(pwin) = row + WIN_TOP(pwin) = max (1, WIN_TOP(pwin)) + + if (col + ncols - 1 > maxcol) + WIN_LEFT(pwin) = maxcol - ncols + 1 + else + WIN_LEFT(pwin) = col + WIN_LEFT(pwin) = max (1, WIN_LEFT(pwin)) + + WIN_BOT(pwin) = min (maxrow, WIN_TOP(pwin) + nrows - 1) + WIN_RIGHT(pwin) = min (maxcol, WIN_LEFT(pwin) + ncols - 1) + + # Set the remaining fields of the window + + WIN_CURROW(pwin) = 1 + WIN_CURCOL(pwin) = 1 + WIN_CLEAR(pwin) = NO + WIN_LEAVE(pwin) = NO + WIN_SCROLL(pwin) = NO + WIN_HIDDEN(pwin) = NO + WIN_BOXED(pwin) = NO + WIN_ATRIB(pwin) = A_NORM + + if (saved == NO) { + WIN_BUFFER(pwin) = NULL + } else { + call getscreen (WIN_RECT(pwin), WIN_BUFFER(pwin)) + } + + WIN_FUNC(pwin) = NULL + WIN_DATA(pwin) = NULL + + # Erase the window + + call werase (win) + + # Return window number + + return (win) +end diff --git a/pkg/utilities/nttools/tedit/display/curses/omkpkg b/pkg/utilities/nttools/tedit/display/curses/omkpkg new file mode 100644 index 00000000..21c3c249 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/omkpkg @@ -0,0 +1,65 @@ + +# Update the newdisp library. +# Author: B.Simon 26-SEP-90 + +$set XFLAGS = "-fgq $(XFLAGS)" +$call default +$exit + +debug: + $set XFLAGS = "-fgq $(XFLAGS)" + $call default + ; + +strip: + $delete newdisp.a + $call default + ; + +update: +default: + $checkout newdisp.a ../../ + $update newdisp.a + $checkin newdisp.a ../../ + ; + +newdisp.a: + addch.x + addstr.x "window.h" "window.com" + bindstruct.x "window.h" "window.com" + box.x "window.h" "window.com" + clear.x "window.h" "window.com" + clearok.x "window.h" "window.com" + clrtobot.x "window.h" "window.com" + clrtoeol.x "window.h" "window.com" + delch.x "window.h" "window.com" + deleteln.x "window.h" "window.com" + delwin.x "window.h" "window.com" + echo.x "window.h" "window.com" + endwin.x "window.h" "window.com" + erase.x "window.h" "window.com" + freescreen.x + getch.x "window.h" "window.com" + getscreen.x + getstr.x "window.h" "window.com" + getstruct.x "window.h" "window.com" + getyx.x "window.h" "window.com" + hidewin.x "window.h" "window.com" + inch.x "window.h" "window.com" + initscr.x "window.h" "window.com" + insch.x "window.h" "window.com" + insertln.x "window.h" "window.com" + leaveok.x "window.h" "window.com" + move.x "window.h" "window.com" + mvwin.x "window.h" "window.com" + newwin.x "window.h" "window.com" + putscreen.x + refresh.x "window.h" "window.com" + savewin.x "window.h" "window.com" + scrollok.x "window.h" "window.com" + showwin.x "window.h" "window.com" + standout.x "window.h" "window.com" + wdimen.x "window.h" "window.com" + winstat.x "window.h" "window.com" + wslide.x + ; diff --git a/pkg/utilities/nttools/tedit/display/curses/putscreen.x b/pkg/utilities/nttools/tedit/display/curses/putscreen.x new file mode 100644 index 00000000..83bb4966 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/putscreen.x @@ -0,0 +1,84 @@ +include "../curses.h" + +# PUTSCREEN -- Copy buffer back onto screen +# +# B.Simon 27-Sep-90 Original + +procedure putscreen (source, buffer) + +int source[RSIZE] # i: Rectangle to be restored +pointer buffer # i: Buffer +#-- + +bool clear +int blank, dest[RSIZE] +int maxcol, maxrow, ncols, nrows, icol, jcol, irow +pointer sp, buf, ptr, scr + +data blank / ' ' / + +bool ps_intersect() +int ps_width(), ps_height() +pointer ps_screen() + +begin + # Clip rectangle at screen boundary + + maxcol = ps_width () + maxrow = ps_height () + if (! ps_intersect (source, maxrow, maxcol, dest)) + return + + call smark (sp) + ncols = RWIDTH(dest) + nrows = RHEIGHT(dest) + + # If the buffer pointer is null, + # copy the current screen contents instead + + if (buffer != NULL) { + buf = buffer + } else { + call salloc (buf, nrows*ncols, TY_CHAR) + + ptr = buf + scr = ps_screen (RTOP(dest), RLEFT(dest)) + do irow = 1, nrows { + call amovc (Memc[scr], Memc[ptr], ncols) + scr = scr + maxcol + ptr = ptr + ncols + } + } + + # See if clearing the screen first would be faster + # if so, do it + + clear = ncols == maxcol + if (clear) + call ps_fill (dest, blank, A_NORM) + + # Copy buffer to screen using ps_wrtcells + + do irow = RTOP(dest), RBOT(dest) { + icol = 1 + jcol = ncols + + # If the screen has been cleared, don't write blanks + + if (clear) { + while (icol <= ncols && Memc[buf+icol-1] == blank) + icol = icol + 1 + while (jcol >= icol && Memc[buf+jcol-1] == blank) + jcol = jcol - 1 + } + + if (jcol >= icol) { + call ps_wrtcells (irow, RLEFT(dest)+icol-1, + Memc[buf+icol-1], jcol-icol+1) + } + + buf = buf + ncols + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tedit/display/curses/refresh.x b/pkg/utilities/nttools/tedit/display/curses/refresh.x new file mode 100644 index 00000000..b65885d8 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/refresh.x @@ -0,0 +1,42 @@ +include "../curses.h" +include "window.h" + +# REFRESH -- Bring the terminal screen up to date +# +# B.Simon 02-Oct-90 Original + +procedure refresh () + +#-- + +begin + call wrefresh (STDSCR) +end + +procedure wrefresh (win) + +int win # i: Window descriptor +#-- +include "window.com" + +int rect[RSIZE] +pointer pwin + +begin + pwin = warray[win] + + # If the clear flag is set, redraw the contents of the window + + if (WIN_CLEAR(pwin) == YES) { + WIN_CLEAR(pwin) = NO + call wrect (win, YES, rect) + call putscreen (rect, NULL) + + if (WIN_LEAVE(pwin) == NO) { + call ps_setcur (WIN_TOP(pwin)+WIN_CURROW(pwin)-1, + WIN_LEFT(pwin)+WIN_CURCOL(pwin)-1) + } + } + + call ps_synch +end diff --git a/pkg/utilities/nttools/tedit/display/curses/savewin.x b/pkg/utilities/nttools/tedit/display/curses/savewin.x new file mode 100644 index 00000000..6be4bc72 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/savewin.x @@ -0,0 +1,23 @@ +include "window.h" + +# SAVEWIN -- Save characters under window when a window is created +# +# B.Simon 18-Oct-90 Original + +procedure savewin () + +#-- +include "window.com" + +begin + saved = YES +end + +procedure nosavewin () + +#-- +include "window.com" + +begin + saved = NO +end diff --git a/pkg/utilities/nttools/tedit/display/curses/scrollok.x b/pkg/utilities/nttools/tedit/display/curses/scrollok.x new file mode 100644 index 00000000..dfbb3317 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/scrollok.x @@ -0,0 +1,21 @@ +include "window.h" + +# SCROLLOK -- Set the scroll flag for a window +# +# B.Simon 02-Oct-90 Original + +procedure scrollok (win, flag) + +int win # i: Window descriptor +bool flag # i: Flag value +#-- +include "window.com" + +pointer pwin +int btoi() + +begin + pwin = warray[win] + WIN_SCROLL(pwin) = btoi (flag) + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/showwin.x b/pkg/utilities/nttools/tedit/display/curses/showwin.x new file mode 100644 index 00000000..66d4c866 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/showwin.x @@ -0,0 +1,39 @@ +include "../curses.h" +include "window.h" + +# SHOWWIN -- Show a previously hidden window +# +# B.Simon 28-Sep-90 Original + +procedure showwin (win) + +int win # i: Window descriptor +#-- +include "window.com" + +int rect[RSIZE] +pointer pwin, buffer + +begin + pwin = warray[win] + + # Don't do anything if the window is already visible + + if (WIN_HIDDEN(pwin) == NO) + return + + # Save the screen under the window in a buffer + # and display the window's contents + + call wrect (win, YES, rect) + call getscreen (rect, buffer) + call putscreen (rect, WIN_BUFFER(pwin)) + + # Copy the screen buffer into the window's buffer and + # mark the window as visible + + call freescreen (WIN_BUFFER(pwin)) + WIN_BUFFER(pwin) = buffer + WIN_HIDDEN(pwin) = NO + +end diff --git a/pkg/utilities/nttools/tedit/display/curses/standout.x b/pkg/utilities/nttools/tedit/display/curses/standout.x new file mode 100644 index 00000000..855dab58 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/standout.x @@ -0,0 +1,48 @@ +include "../curses.h" +include "window.h" + +# STANDOUT -- Put the window in standout mode +# +# B.Simon 02-Oct-90 Original + +procedure standout () + +#-- + +begin + call wstandout (STDSCR) +end + +procedure wstandout (win) + +int win # i: Window descriptor +#-- +include "window.com" + +pointer pwin + +begin + pwin = warray[win] + WIN_ATRIB(pwin) = A_STANDOUT +end + +procedure standend () + +#-- + +begin + call wstandend (STDSCR) +end + +procedure wstandend (win) + +int win # i: Window descriptor +#-- +include "window.com" + +pointer pwin + +begin + pwin = warray[win] + WIN_ATRIB(pwin) = A_NORM +end diff --git a/pkg/utilities/nttools/tedit/display/curses/wdimen.x b/pkg/utilities/nttools/tedit/display/curses/wdimen.x new file mode 100644 index 00000000..55d5a6cf --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/wdimen.x @@ -0,0 +1,45 @@ +include "../curses.h" +include "window.h" + +# WDIMEN -- Return dimensions of a window +# +# B.Simon 11-Oct-90 Original + +procedure wdimen (win, nrows, ncols) + +int win # i: Window descriptor +int nrows # o: Window height +int ncols # o: Window width +#-- +int rect[RSIZE] + +begin + call wrect (win, NO, rect) + + nrows = RHEIGHT(rect) + ncols = RWIDTH(rect) +end + +# WRECT -- Get the rectangle containing the window + +procedure wrect (win, border, rect) + +int win # i: Window descriptor +int border # i: Include border in dimensions? +int rect[RSIZE] # o: Rectangle containing window dimensions +#-- +include "window.com" + +pointer pwin + +begin + pwin = warray[win] + if (border == NO || WIN_BOXED(pwin) == NO) { + RASG(rect, WIN_TOP(pwin), WIN_LEFT(pwin), + WIN_BOT(pwin), WIN_RIGHT(pwin)) + + } else { + RASG(rect, WIN_TOP(pwin)-1, WIN_LEFT(pwin)-1, + WIN_BOT(pwin)+1, WIN_RIGHT(pwin)+1) + } +end diff --git a/pkg/utilities/nttools/tedit/display/curses/window.com b/pkg/utilities/nttools/tedit/display/curses/window.com new file mode 100644 index 00000000..74b0a38c --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/window.com @@ -0,0 +1,7 @@ +# WINDOW.COM -- Global variables used by the curses subroutines + +int saved # Save rectangle under window when creating +int echoed # Echo characters +pointer warray[MAXWIN] # Array holding window descriptors + +common /window/ saved, echoed, warray diff --git a/pkg/utilities/nttools/tedit/display/curses/window.h b/pkg/utilities/nttools/tedit/display/curses/window.h new file mode 100644 index 00000000..41141580 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/window.h @@ -0,0 +1,28 @@ +# WINDOW.H -- Window structure definitions and macros + +define MAXWIN 50 # Maximum number of windows +define LEN_WINSTRUCT 15 # Length of window structure + +# definition of window structure + +define WIN_TOP Memi[$1] # Window's top row +define WIN_LEFT Memi[$1+1] # Window's leftmost column +define WIN_BOT Memi[$1+2] # Window's bottom row +define WIN_RIGHT Memi[$1+3] # Window's rightmost column +define WIN_CURROW Memi[$1+4] # Cursor row relative to window +define WIN_CURCOL Memi[$1+5] # Cursor column relative to window +define WIN_CLEAR Memi[$1+6] # Redraw window when refreshed +define WIN_LEAVE Memi[$1+7] # Leave cursor after redraw +define WIN_SCROLL Memi[$1+8] # Window will scroll +define WIN_HIDDEN Memi[$1+9] # Window is hidden +define WIN_BOXED Memi[$1+10] # Window is boxed +define WIN_ATRIB Memi[$1+11] # Character attribute of window +define WIN_BUFFER Memi[$1+12] # Holds characters under the window +define WIN_FUNC Memi[$1+13] # Function bound to window +define WIN_DATA Memi[$1+14] # Data structure bound to window + +# Macros used to manipulate rectangle + +define WIN_RECT Memi[$1] +define WIN_WIDTH (WIN_RIGHT($1) - WIN_LEFT($1) + 1) +define WIN_HEIGHT (WIN_BOT($1) - WIN_TOP($1) + 1) diff --git a/pkg/utilities/nttools/tedit/display/curses/winstat.x b/pkg/utilities/nttools/tedit/display/curses/winstat.x new file mode 100644 index 00000000..e89e3ca6 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/winstat.x @@ -0,0 +1,51 @@ +include "../curses.h" +include "window.h" + +# WINSTAT -- Retrieve a field from a window structure + +int procedure winstat (win, what) + +int win # i: Window descriptor +int what # i: Field to retrieve +#-- +include "window.com" + +int value +pointer pwin + +string badcode "Unrecognized argument to winstat" + +begin + pwin = warray[win] + + switch (what) { + case W_TOP: + value = WIN_TOP(pwin) + case W_LEFT: + value = WIN_LEFT(pwin) + case W_BOT: + value = WIN_BOT(pwin) + case W_RIGHT: + value = WIN_RIGHT(pwin) + case W_CURROW: + value = WIN_CURROW(pwin) + case W_CURCOL: + value = WIN_CURCOL(pwin) + case W_CLEAR: + value = WIN_CLEAR(pwin) + case W_LEAVE: + value = WIN_LEAVE(pwin) + case W_SCROLL: + value = WIN_SCROLL(pwin) + case W_HIDDEN: + value = WIN_HIDDEN(pwin) + case W_BOXED: + value = WIN_BOXED(pwin) + case W_ATRIB: + value = WIN_ATRIB(pwin) + default: + call error (1, badcode) + } + + return (value) +end diff --git a/pkg/utilities/nttools/tedit/display/curses/wslide.x b/pkg/utilities/nttools/tedit/display/curses/wslide.x new file mode 100644 index 00000000..b57f68da --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/curses/wslide.x @@ -0,0 +1,91 @@ +include "../curses.h" + +# WSLIDE -- Slide a window's rectangle on the screen +# +# B.Simon 25-Sep-90 Original + +procedure wslide (source, dir, dist) + +int source[RSIZE] # i: Rectangle +int dir # i: Direction (from display.h) +int dist # i: Distance (> 0) +#-- +int blank, dest[RSIZE], rect[RSIZE] +int maxcol, maxrow, ncols, irow, icol +pointer sp, buffer, oldscr + +data blank / ' ' / + +bool ps_slide(), ps_intersect() +int ps_width(), ps_height() +pointer ps_screen() + +begin + # First try to slide the rectangle with ps_slide + # (move by using insert and delete control sequences) + + if (ps_slide (source, dir, dist)) + return + + # If this doesn't work, redraw the rectangle from + # the screen buffer using ps_wrtcells and ps_fill + + # The left and write scrolls must first be written + # to a buffer to avoid the problem with array overlap + # when updating the screen buffer + + maxcol = ps_width () + maxrow = ps_height () + if (! ps_intersect (source, maxrow, maxcol, dest)) + return + + call smark(sp) + ncols = RWIDTH(dest) + call salloc (buffer, ncols+dist, TY_CHAR) + + switch (dir) { + case DIR_UP: + oldscr = ps_screen (RTOP(dest), RLEFT(dest)) + do irow = RTOP(dest), RBOT(dest)-dist { + call ps_wrtcells (irow-dist, RLEFT(dest), Memc[oldscr], ncols) + oldscr = oldscr + maxcol + } + + RASG (rect, max(RTOP(dest), RBOT(dest)-dist+1), RLEFT(dest), + RBOT(dest), RRIGHT(dest)) + call ps_fill (rect, blank, A_NORM) + + case DIR_DOWN: + oldscr = ps_screen (RBOT(dest), RLEFT(dest)) + do irow = RBOT(dest), RTOP(dest)+dist, -1 { + call ps_wrtcells (irow+dist, RLEFT(dest), Memc[oldscr], ncols) + oldscr = oldscr - maxcol + } + + RASG (rect, RTOP(dest), RLEFT(dest), + min(RBOT(dest), RTOP(dest)+dist-1), RRIGHT(dest)) + call ps_fill (rect, blank, A_NORM) + + case DIR_LEFT: + icol = RLEFT(dest) - dist + oldscr = ps_screen (RTOP(dest), RLEFT(dest)) + do irow = RTOP(dest), RBOT(dest) { + call amovc (Memc[oldscr], Memc[buffer], ncols) + call amovkc (blank, Memc[buffer+ncols], ncols-dist) + + call ps_wrtcells (irow, icol, Memc[buffer], ncols) + oldscr = oldscr + maxcol + } + case DIR_RIGHT: + icol = RLEFT(dest) + dist + oldscr = ps_screen (RTOP(dest), RLEFT(dest)) + do irow = RTOP(dest), RBOT(dest) { + call amovc (Memc[oldscr], Memc[buffer], ncols) + + call ps_wrtcells (irow, icol, Memc[buffer], ncols) + oldscr = oldscr + maxcol + } + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tedit/display/forms/README b/pkg/utilities/nttools/tedit/display/forms/README new file mode 100644 index 00000000..cd5feeca --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/README @@ -0,0 +1,115 @@ +The forms procedures give an example of a display handling library +built on top of the curses routines. The forms procedures divide the +terminal screen into two windows, the form and prompt window. The +form window contains the form fields. Each field in the form occupies +one line on the screen with the field name on the left side of the +line and the field value on the right side separated by an equals +sign. If the number of fields in the form exceed the number of lines +in the form window, a portion of the fields will be displayed, which +the user can scroll through. The prompt window is used to read user +input and display messages. The first line contains a message, +typically used to list the possible commands, and the second line +contains the user input. + +The following two procedures are used to initialize and terminate the +form handling. The first procedure, fm_begin, calls the keyboard and +screen initialization routines, and initializes some global variables. +The second procedure, fm_end, calls the keyboard and screen +termination routines. + +procedure fm_begin () +procedure fm_end () + +The next three procedures handle the form window of the screen. The +first procedure, fm_mkform(), associates a form with a window. The +second procedure, fm_getform(), gets user input from the form. The +third procedure, fm_endform(), frees the data structure associated +with the form. + +The first procedure has the following calling sequence: + +procedure fm_mkform (win, nfield, lenname, lenvalue, title, ftype, fname) + +int win # i: Window descriptor +int nfield # i: Number of fields in form +int lenname # i: Declared length of field name +int lenvalue # i: Declared length of field value +char title[ARB] # i: Form title +int ftype[ARB] # i: Data types of fields +char fname[lenname,ARB] # i: Names of fields + +The first argument, win, is the window descriptor. It is created by +calling newwin(), the curses procedure which creates windows. The next +three arguments are used to compute the size of the structure which +holds the form. The number of fields can be greater than the height of +the window, as the window will scroll up and down. But the combined +length of the field name and value must be less than the width of the +window, as it will not scroll side to side. The title is a string that +is printed on the title bar, which is the bottom row of the form. The +title bar also contains the help key escape sequence. Three items of +information are associated with each field: a type, a name, and a +value. The type is an integer with the same meaning used by the table +interface: a negative number if the field is a string whose magnitude +is equal to the maximum string length or a positive integer equal to +the spp type code if the field is not a string. The type is used to +check the field value, the procedure will not let the user enter a +value of a different type. Each field name is printed on a separate +line of the form followed by an equals sign. + +The second procedure, fm_getform, is used to read or display the +values associated with the fields of the form. It has the following +calling sequence: + +procedure fm_getform (win, redraw, lenvalue, fvalue) + +int win # i: Window descriptor +bool redraw # i: Redraw screen? +int lenvalue # i: Declared length of field value +char fvalue[lenvalue,ARB] # u: Values in fields + +The first argument is the window descriptor of the window associated +with the form. If the second argument, redraw is set to true, the +window is redrawn when the procedure begins, otherwise the window is +unchanged. Redraw should set to true the first time this procedure is +called. The last argument, fvalue, contains the values that are +displayed on the form. The user updates these values by editing the +form on the screen. When the user has finished updating the values, +the modified values are returned to the calling procedure. + +The third procedure frees the form data structure. After freeing the +data structure, the window should be closed by calling delwin. This +procedure has the following calling sequence: + +procedure fm_clsform (win) + +int win # i: Window descriptor + + +The next procedure, fm_prompt, handles the prompt window on the screen. +It has the following calling sequence: + +int procedure fm_prompt (commands, message) + +char commands[ARB] # i: List of commands +char message[ARB] # i: Message to print in prompt area + +The list of commands is a string containing the possible commands. This +string is formatted like the dictionary in strdic: the first character +in the string is a command separator which appears between the commands +in the string. The message is displayed on the top line of the prompt +area. If the message is a null string, the command string is displayed +instead. The user enters one of the commands and presses carriage +return. The procedure returns the number of the command that the user +entered if the command is legal, or beeps and displays the list of +commands if it is not. If the list of commands is a null string, the +procedure displays the message in the prompt area and returns a value +of zero without looking for user input. + +The last procedure displays the help window. This window covers the +entire screen. Its argument is the currently active window. It is +passed so that the cursor can be restored to its previous position +when the procedure is finished. + +procedure fm_help (win) + +int win # i: Window which currently is active diff --git a/pkg/utilities/nttools/tedit/display/forms/fmbegin.x b/pkg/utilities/nttools/tedit/display/forms/fmbegin.x new file mode 100644 index 00000000..8cf78aba --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/fmbegin.x @@ -0,0 +1,20 @@ +# FM_BEGIN -- Initialize form handler +# +# B.Simon 25-Jan-88 Original +# B.Simon 11-Oct-90 Rewritten to use curses + +procedure fm_begin () + +#-- +include "forms.com" + +begin + # Initialize curses + + call initscr + + # Initialize global variables + + helpwin = 0 + +end diff --git a/pkg/utilities/nttools/tedit/display/forms/fmcheck.x b/pkg/utilities/nttools/tedit/display/forms/fmcheck.x new file mode 100644 index 00000000..d7fa95d4 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/fmcheck.x @@ -0,0 +1,98 @@ +include +include +include + +# FM_CHECK -- Check a string against a data type +# +# B.Simon 28-Mar-91 Modified to check INDEF correctly + +bool procedure fm_check (datatype, str) + +int datatype # i: Datatype to check +char str[ARB] # i: String to be checked +#-- +bool match +double strval +int ic, nc, lextype, strtype +pointer sp, temp + +string yorn "|yes|no|" + +bool streq() +int strlen(), lexnum(), ctod(), strdic() + +begin + # Don't check null strings + + if (str[1] == EOS) + return (true) + + call smark (sp) + call salloc (temp, SZ_LINE, TY_CHAR) + + if (datatype < 0) + + # The only check on string types is that they not exceed their + # maximum length + + match = strlen (str) <= -(datatype) + + else { + + # Get the data type of the string + # Reduce this to character, integer or real + # Get the value of the string if it is not character + + if (streq (str, "INDEF")) { + strtype = datatype + strval = 0.0 + + } else { + ic = 1 + lextype = lexnum (str, ic, nc) + + for (ic = ic + nc; IS_WHITE(str[ic]); ic = ic + 1) + ; + if (str[ic] != EOS) + lextype = LEX_NONNUM + + if (lextype == LEX_HEX || lextype == LEX_NONNUM) { + strtype = TY_CHAR + strval = 0.0 + } else { + if (lextype == LEX_REAL) + strtype = TY_REAL + else + strtype = TY_INT + + ic = 1 + nc = ctod (str, ic, strval) + strval = abs (strval) + } + } + + # See if the string matches the expected datatype + + switch (datatype) { + case TY_BOOL: + match = strdic (str, Memc[temp], SZ_LINE, yorn) > 0 + case TY_CHAR: + match = strlen (str) <= 1 + case TY_SHORT: + match = strtype == TY_INT && strval <= MAX_SHORT + case TY_INT: + match = strtype == TY_INT && strval <= MAX_INT + case TY_LONG: + match = strtype == TY_INT && strval <= MAX_LONG + case TY_REAL: + match = strtype != TY_CHAR && strval <= MAX_REAL + case TY_DOUBLE: + match = strtype != TY_CHAR && strval <= MAX_DOUBLE + default: + match = true + } + } + + call sfree (sp) + return (match) +end diff --git a/pkg/utilities/nttools/tedit/display/forms/fmend.x b/pkg/utilities/nttools/tedit/display/forms/fmend.x new file mode 100644 index 00000000..353ebfe0 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/fmend.x @@ -0,0 +1,12 @@ +# FM_END -- Terminate form handler +# +# B.Simon 25-Jan-89 Original +# B.Simon 11-Oct-90 Rewritten to use curses + +procedure fm_end () + +#-- + +begin + call endwin +end diff --git a/pkg/utilities/nttools/tedit/display/forms/fmgetform.x b/pkg/utilities/nttools/tedit/display/forms/fmgetform.x new file mode 100644 index 00000000..ebc6d143 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/fmgetform.x @@ -0,0 +1,89 @@ +include "../curses.h" +include "formfn.h" + +# FM_GETFORM -- Get user input from a form +# +# B.Simon 27-Jan-89 Original +# B.Simon 12-Dec-90 Rewritten to use curses + +procedure fm_getform (win, redraw, lenvalue, fvalue) + +int win # i: Window descriptor +bool redraw # i: Redraw screen? +int lenvalue # i: Declared length of field value +char fvalue[lenvalue,ARB] # u: Values in fields +#-- +bool draw +int ifield, curfield, topfield, botfield, ch +pointer data, value + +bool fm_check() +int k_get() + +begin + # Get pointer to form data structure + + call wgetstruct (win, data) + + # Initialize data structure + + FM_FIELD(data) = 1 + FM_CHANGE(data) = NO + + # Copy values to data structure + + value = FM_VALARY(data) + do ifield = 1, FM_NFIELD(data) { + call strcpy (fvalue[1,ifield], Memc[value], lenvalue) + value = value + FM_LENVAL(data) + 1 + } + + # Let user update form + + draw = redraw + + curfield = 1 + topfield = 1 + botfield = min (FM_NFIELD(data), topfield + FM_NPAGE(data) - 1) + + repeat { + + # Redraw form and move cursor + + if (draw) { + topfield = max (1, curfield - FM_NPAGE(data) / 2) + botfield = min (FM_NFIELD(data), topfield + FM_NPAGE(data) - 1) + call fm_redraw (win, topfield) + } + + call wmove (win, curfield-topfield+1, FM_LENNAM(data)+4) + + value = FM_VALPTR(data,curfield) + call weditstr (win, Memc[value], FM_LENVAL(data)) + + ch = k_get () + + if (FM_CHANGE(data) == YES) { + if (! fm_check (FM_TYPE(data,curfield), + Memc[FM_VALPTR(data,curfield)])) { + call ps_beep + ch = EOS + next + } + } + + curfield = FM_FIELD(data) + FM_CHANGE(data) = NO + draw = curfield < topfield || curfield > botfield + + } until (ch == K_EXIT) + + # Copy form values to output array + + value = FM_VALARY(data) + do ifield = 1, FM_NFIELD(data) { + call strcpy (Memc[value], fvalue[1,ifield], lenvalue) + value = value + FM_LENVAL(data) + 1 + } + +end diff --git a/pkg/utilities/nttools/tedit/display/forms/fmhelp.x b/pkg/utilities/nttools/tedit/display/forms/fmhelp.x new file mode 100644 index 00000000..8615c031 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/fmhelp.x @@ -0,0 +1,132 @@ +include "../curses.h" + +define COLWIDTH 40 +define LABEL_FLAG 1 +define NAME_FLAG 2 + +# FM_HELP -- Display help window for function key sequences + +procedure fm_help (win) + +int win # i: Window which currently is active +#-- +include "forms.com" + +int key, row, col +int k_get(), winstat() + +begin + # If the help screen was created on a previous call, + # display it, otherwise make a new help screen + + if (helpwin != 0) { + call showwin (helpwin) + } else { + call fm_hmake (helpwin) + } + + # Display help screen and wait for keystroke to hide window + + call refresh + key = k_get () + + # Hide the help window and restore cursor to current window + + call hidewin (helpwin) + + row = winstat (win, W_CURROW) + col = winstat (win, W_CURCOL) + call wmove (win, row, col) + +end + +procedure fm_hmake (hwin) + +pointer hwin # o: help window +#-- +int ic, nrows, ncols, irow, icol, flag +pointer sp, label, name, hline, text, ch + +string htitle "Editing Commands" +string hfooter "(Press any key to continue)" +string hformat "%4w%-12.12s = %-12.12s" + +int newwin(), strlen() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (label, COLWIDTH, TY_CHAR) + call salloc (name, COLWIDTH, TY_CHAR) + call salloc (hline, COLWIDTH, TY_CHAR) + + # Create help message + + hwin = newwin (GIANT, GIANT, 1, 1) + + # Write help screen title + + call wdimen (hwin, nrows, ncols) + icol = (ncols - strlen(htitle)) / 2 + call wmove (hwin, 1, icol) + call wstandout (hwin) + call waddstr (hwin, htitle) + call wstandend (hwin) + + ic = 0 + icol = 0 + irow = 3 + flag = LABEL_FLAG + call k_help (text) + + # Write each (label=name) pair to the help screen + + for (ch = text; Memc[ch] != EOS; ch = ch + 1) { + switch (flag) { + case LABEL_FLAG: + if (Memc[ch] != '=') { + Memc[label+ic] = Memc[ch] + ic = ic + 1 + } else { + Memc[label+ic] = EOS + flag = NAME_FLAG + ic = 0 + } + case NAME_FLAG: + if (Memc[ch] != '\n') { + Memc[name+ic] = Memc[ch] + ic = ic + 1 + } else { + Memc[name+ic] = EOS + flag = LABEL_FLAG + ic = 0 + + # Reformat label/name pair for window + + call sprintf (Memc[hline], COLWIDTH, hformat) + call pargstr (Memc[label]) + call pargstr (Memc[name]) + + # Write string to window + + call wmove (hwin, irow, icol * COLWIDTH + 1) + call waddstr (hwin, Memc[hline]) + + # Calculate next string position + + icol = icol + 1 + if (icol == 2) { + icol = 0 + irow = irow + 1 + } + } + } + } + + # Write help screen footer + + call wmove (hwin, nrows, 1) + call waddstr (hwin, hfooter) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tedit/display/forms/fmmkform.x b/pkg/utilities/nttools/tedit/display/forms/fmmkform.x new file mode 100644 index 00000000..00bc8106 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/fmmkform.x @@ -0,0 +1,82 @@ +include "formfn.h" + +# FM_MKFORM -- Create a form and bind it to a window +# +# B.Simon 27-Jan-89 Original +# B.Simon 15-Oct-90 Rewritten to use curses + +procedure fm_mkform (win, nfield, lenname, lenvalue, title, ftype, fname) + +int win # i: Window descriptor +int nfield # i: Number of fields in form +int lenname # i: Declared length of field name +int lenvalue # i: Declared length of field value +char title[ARB] # i: Form title +int ftype[ARB] # i: Data types of fields +char fname[lenname,ARB] # i: Names of fields +#-- +extern formfn +int nrows, ncols, ifield +pointer data, name, value, type + +begin + # Get the dimensions of the form + + call wdimen (win, nrows, ncols) + + # Allocate data structure + + call malloc (data, LEN_FMSTRUCT, TY_STRUCT) + call malloc (FM_NAMARY(data), (lenname+1)*nfield, TY_CHAR) + call malloc (FM_VALARY(data), (lenvalue+1)*nfield, TY_CHAR) + call malloc (FM_TTLPTR(data), SZ_LINE, TY_CHAR) + call malloc (FM_TYPARY(data), nfield, TY_INT) + + # Initialize data structure + + FM_FIELD(data) = 1 + FM_NFIELD(data) = nfield + FM_NPAGE(data) = nrows - 1 + FM_CHANGE(data) = NO + FM_LENNAM(data) = lenname + FM_LENVAL(data) = lenvalue + call strcpy (title, FM_TITLE(data), SZ_LINE) + + name = FM_NAMARY(data) + value = FM_VALARY(data) + type = FM_TYPARY(data) + + do ifield = 1, nfield { + call strcpy(fname[1,ifield], Memc[name], lenname) + name = name + lenname + 1 + Memc[value] = EOS + value = value + lenvalue + 1 + Memi[type] = ftype[ifield] + type = type + 1 + } + + # Bind data structure and function to window + + call wbindstruct (win, formfn, data) + +end + +procedure fm_clsform (win) + +int win # i: Window descriptor +#-- +pointer data + +begin + # Get the structure pointer + + call wgetstruct (win, data) + + # Free the substructures hanging off the main structure + + call mfree (FM_NAMARY(data), TY_CHAR) + call mfree (FM_VALARY(data), TY_CHAR) + call mfree (FM_TTLPTR(data), TY_CHAR) + call mfree (FM_TYPARY(data), TY_INT) + +end diff --git a/pkg/utilities/nttools/tedit/display/forms/fmprompt.x b/pkg/utilities/nttools/tedit/display/forms/fmprompt.x new file mode 100644 index 00000000..b93ef450 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/fmprompt.x @@ -0,0 +1,70 @@ +# FM_PROMPT -- Get user input from a prompt window +# +# B.Simon 30-Jan-89 Original +# B.Simon 12-Dec-90 Rewritten to use curses + +int procedure fm_prompt (win, commands, message) + +int win # i: Prompt window +char commands[ARB] # i: List of commands +char message[ARB] # i: Message to print in prompt area +#-- +char newline +int option +pointer sp, response, temp + +data newline / '\n' / + +int strdic() + +begin + # Print the message in the window + + call werase (win) + call wmove (win, 1, 1) + if (message[1] == EOS) { + call waddstr (win, commands) + call waddch (win, newline) + } else { + call waddstr (win, message) + call waddch (win, newline) + } + + # Return if no user response is needed + + if (commands[1] == EOS) { + call wrefresh (win) + return (0) + } + + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (response, SZ_LINE, TY_CHAR) + call salloc (temp, SZ_LINE, TY_CHAR) + + # Get the user response + + repeat { + call wgetstr (win, Memc[response], SZ_LINE) + + # Check response against list of commands + + option = strdic (Memc[response], Memc[temp], SZ_LINE, commands) + if (option > 0) + break + + # Try again if response was not valid + + call werase (win) + call wmove (win, 1, 1) + call waddstr (win , commands) + call waddch (win, newline) + call ps_beep + } + + # Return the option number + + call sfree (sp) + return (option) +end diff --git a/pkg/utilities/nttools/tedit/display/forms/fmredraw.x b/pkg/utilities/nttools/tedit/display/forms/fmredraw.x new file mode 100644 index 00000000..71e5b781 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/fmredraw.x @@ -0,0 +1,69 @@ +include "formfn.h" +define SZ_ESCSEQ 20 + +# FM_REDRAW -- Redraw the form + +procedure fm_redraw (win, topfield) + +int win # i: Window descriptor +int topfield # i: Top field on the form to draw +#-- +int nrows, ncols, botfield, ifield +pointer sp, field, footer, escseq, data, name, value + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + call salloc (footer, SZ_LINE, TY_CHAR) + call salloc (escseq, SZ_ESCSEQ, TY_CHAR) + + # Get form data structure + + call wgetstruct (win, data) + + # Get the dimensions of the form + + call wdimen (win, nrows, ncols) + + # Clear screen + + call werase (win) + + # Write the form + + name = FM_NAMPTR(data,topfield) + value = FM_VALPTR(data,topfield) + botfield = min (FM_NFIELD(data), topfield + FM_NPAGE(data) - 1) + + call wmove (win, 1, 1) + do ifield = topfield, botfield { + call sprintf (Memc[field], SZ_LINE, "%*s = %s\n") + call pargi (FM_LENNAM(data)) + call pargstr (Memc[name]) + call pargstr (Memc[value]) + + call waddstr (win, Memc[field]) + + name = name + FM_LENNAM(data) + 1 + value = value + FM_LENVAL(data) + 1 + } + + # Write the footer line + + call k_eseq ("GET_HELP", Memc[escseq], SZ_ESCSEQ) + + call sprintf (Memc[footer], ncols, "%4w%s%*tHelp: %s%*t") + call pargstr (FM_TITLE(data)) + call pargi (ncols-SZ_ESCSEQ) + call pargstr (Memc[escseq]) + call pargi (ncols+1) + + call wmove (win, nrows, 1) + call wstandout (win) + call waddstr (win, Memc[footer]) + call wstandend (win) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tedit/display/forms/formfn.h b/pkg/utilities/nttools/tedit/display/forms/formfn.h new file mode 100644 index 00000000..b3afbc75 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/formfn.h @@ -0,0 +1,20 @@ +# FORMFN.H -- Data structure used by formfn() + +define LEN_FMSTRUCT 10 + +define FM_FIELD Memi[$1] # Current field +define FM_NFIELD Memi[$1+1] # Number of fields on form +define FM_NPAGE Memi[$1+2] # Number of fields in window +define FM_CHANGE Memi[$1+3] # Has field been changed ? +define FM_LENNAM Memi[$1+4] # Length of name field +define FM_LENVAL Memi[$1+5] # Length of value field +define FM_NAMARY Memi[$1+6] # Array of field names +define FM_VALARY Memi[$1+7] # Array of field values +define FM_TTLPTR Memi[$1+8] # Title array +define FM_TYPARY Memi[$1+9] # Array of field types + +define FM_NAMPTR FM_NAMARY($1)+(($2)-1)*(FM_LENNAM($1)+1) +define FM_VALPTR FM_VALARY($1)+(($2)-1)*(FM_LENVAL($1)+1) + +define FM_TITLE Memc[FM_TTLPTR($1)] +define FM_TYPE Memi[FM_TYPARY($1)+($2)-1] diff --git a/pkg/utilities/nttools/tedit/display/forms/formfn.x b/pkg/utilities/nttools/tedit/display/forms/formfn.x new file mode 100644 index 00000000..b060a87c --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/formfn.x @@ -0,0 +1,278 @@ +include +include "../curses.h" +include "formfn.h" + +# FORMFN -- Function that processes form input +# +# B.Simon 12-Dec-90 Original + +procedure formfn (win, str, maxch) + +int win # i: Window descriptor +char str[ARB] # u: String containing line +int maxch # i: Maximum line length +#-- +int row, col, ch, ic, jc, mc, nc +pointer sp, data, buffer + +int strlen(), k_get(), winstat() + +begin + ic = 0 + nc = strlen (str) + + call wgetstruct (win, data) + row = winstat (win, W_CURROW) + col = winstat (win, W_CURCOL) + + call smark (sp) + call salloc (buffer, SZ_LINE, TY_CHAR) + Memc[buffer] = EOS + + while (nc < maxch) { + + # Read character from keyboard + + call ps_synch + ch = k_get () + + # Check for carriage return + + if (ch == '\r') { + if (FM_FIELD(data) < FM_NFIELD(data)) { + FM_FIELD(data) = FM_FIELD(data) + 1 + break + } + } + + if (IS_PRINT(ch)) { + ic = ic + 1 + nc = nc + 1 + FM_CHANGE(data) = YES + + if (ic == nc) { + str[ic] = ch + str[ic+1] = EOS + call waddstr (win, str[ic]) + + } else { + do jc = nc-1, ic, -1 + str[jc+1] = str[jc] + + str[ic] = ch + call winsch (win, str[ic]) + } + + } else { + switch (ch) { + case K_UP: # Move up one field + if (FM_FIELD(data) > 1) { + FM_FIELD(data) = FM_FIELD(data) - 1 + break + } + + case K_DOWN: # Move down one field + if (FM_FIELD(data) < FM_NFIELD(data)) { + FM_FIELD(data) = FM_FIELD(data) + 1 + break + } + + case K_RIGHT: # Move right one column + if (ic < nc) { + ic = ic + 1 + call wmove (win, row, col+ic) + } + + case K_LEFT: # Move left one column + if (ic > 0) { + ic = ic - 1 + call wmove (win, row, col+ic) + } + + case K_NEXTW: # Move forwards one word + call mvword_next (str, ic, jc) + + if (jc > ic) { + ic = jc + call wmove (win, row, col+ic) + } + + + case K_PREVW: # Move backwards one word + call mvword_prev (str, ic, jc) + + if (jc < ic) { + ic = jc + call wmove (win, row, col+ic) + } + + + case K_NEXTP: # Move forwards one screen + if (FM_FIELD(data) < FM_NFIELD(data)) { + FM_FIELD(data) = min (FM_FIELD(data) + FM_NPAGE(data), + FM_NFIELD(data)) + break + } + + case K_PREVP: # Move backwards one screen + if (FM_FIELD(data) > 1) { + FM_FIELD(data) = max (FM_FIELD(data) - FM_NPAGE(data), + 1) + break + } + + case K_HOME: # Move to first field + if (FM_FIELD(data) > 1) { + FM_FIELD(data) = 1 + break + } + + case K_END: # Move to last field + if (FM_FIELD(data) < FM_NFIELD(data)) { + FM_FIELD(data) = FM_NFIELD(data) + break + } + + case K_BOL: # Move to first column in line + if (ic > 0) { + ic = 0 + call wmove (win, row, col) + } + + case K_EOL: # Move to last column in line + if (ic < nc) { + ic = nc + call wmove (win, row, col+ic) + } + + case K_DEL: # Delete character underneath cursor + if (ic < nc) { + FM_CHANGE(data) = YES + mc = strlen (Memc[buffer]) + + Memc[buffer+mc] = str[ic+1] + Memc[buffer+mc+1] = EOS + + call amovc (str[ic+2], str[ic+1], nc-ic) + + call wdelch (win) + nc = nc - 1 + } + + case K_BS: # Delete character to left of cursor + if (ic > 0) { + FM_CHANGE(data) = YES + mc = strlen (Memc[buffer]) + + call amovc (Memc[buffer], Memc[buffer+1], mc+1) + Memc[buffer] = str[ic] + + ic = ic - 1 + call amovc (str[ic+2], str[ic+1], nc-ic) + + call wmove (win, row, col+ic) + call wdelch (win) + nc = nc - 1 + } + + case K_DWORD: # Delete one word + call mvword_next (str, ic, jc) + + if (jc > ic) { + FM_CHANGE(data) = YES + mc = strlen (Memc[buffer]) + + call strcpy (str[ic+1], Memc[buffer+mc], jc-ic) + call amovc (str[jc+1], str[ic+1], nc-jc+1) + + call wclrtoeol (win) + call waddstr (win, str[ic+1]) + call wmove (win, row, col+ic) + nc = nc - (jc - ic) + } + + case K_DLINE: # Delete entire line + if (nc > 0) { + FM_CHANGE(data) = YES + + call strcpy (str[ic+1], Memc[buffer], nc-ic) + str[ic+1] = EOS + + call wclrtoeol (win) + nc = ic + } + + case K_UNDCHR: # Undelete a character + mc = strlen (Memc[buffer]) + if (mc > 0) { + call amovc (str[ic+1], str[ic+2], nc-ic+1) + str[ic+1] = Memc[buffer+mc-1] + + Memc[buffer+mc-1] = EOS + call winsch (win, str[ic+1]) + + ic = ic + 1 + nc = nc + 1 + } + + case K_UNDWRD: # Undelete a word + mc = strlen (Memc[buffer]) + call mvword_prev (Memc[buffer], mc, jc) + + mc = mc - jc + if (mc > 0) { + call amovc (str[ic+1], str[ic+mc+1], nc-ic+1) + call amovc (Memc[buffer+jc], str[ic+1], mc) + + Memc[buffer+jc] = EOS + call wclrtoeol (win) + call waddstr (win, str[ic+1]) + + ic = ic + mc + nc = nc + mc + call wmove (win, row, col+ic) + } + + case K_UNDLIN: # Undelete a line + mc = strlen (Memc[buffer]) + if (mc > 0) { + call amovc (str[ic+1], str[ic+mc+1], nc-ic+1) + call amovc (Memc[buffer], str[ic+1], mc) + + Memc[buffer] = EOS + call wclrtoeol (win) + call waddstr (win, str[ic+1]) + + ic = ic + mc + nc = nc + mc + call wmove (win, row, col+ic) + } + + case K_HELP: # Display help screen + call fm_help (win) + + case K_PAINT: # Redraw the screen + call clearok (STDSCR, true) + call wrefresh (STDSCR) + call wmove (win, row, col+ic) + + case K_EXIT: # Exit procedure + break + + default: # Any other character + call ps_beep + } + } + } + + # Terminate string with EOS and push back character + # that terminated input + + if (nc >= maxch) + ch = EOS + + str[nc+1] = EOS + call k_pushbk (ch) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tedit/display/forms/forms.com b/pkg/utilities/nttools/tedit/display/forms/forms.com new file mode 100644 index 00000000..2e948a0c --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/forms.com @@ -0,0 +1,5 @@ +# FORMS.COM -- Global variables used by forms procedures + +int helpwin # Function key help window + +common /form/ helpwin diff --git a/pkg/utilities/nttools/tedit/display/forms/linefn.h b/pkg/utilities/nttools/tedit/display/forms/linefn.h new file mode 100644 index 00000000..c263dfce --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/linefn.h @@ -0,0 +1,8 @@ +# LINEFN.H -- Data structure associated with linefn() + +define LEN_LINSTRUCT 4 + +define LIN_ROW Memi[$1] # Cursor row +define LIN_COL Memi[$1+1] # Cursor column +define LIN_ICHAR Memi[$1+2] # Index to current character +define LIN_LAST Memi[$1+3] # Character which caused return diff --git a/pkg/utilities/nttools/tedit/display/forms/linefn.x b/pkg/utilities/nttools/tedit/display/forms/linefn.x new file mode 100644 index 00000000..c122795a --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/linefn.x @@ -0,0 +1,134 @@ +include "../curses.h" +include "linefn.h" + +# LINEFN -- Function that processes a line of input in a window + +procedure linefn (win, ch, maxch, str, data, done) + +int win # i: Window descriptor +int ch # i: Keyboard character +int maxch # i: Maximum line length +char str[ARB] # io: String containing line +pointer data # io: Line data structure +bool done # o: Flag indicating line is done +#-- +int ic, jc, nc +int strlen() + +begin + done = false + if (LIN_ROW(data) == 0 || LIN_COL(data) == 0) + call getyx (win, LIN_ROW(data), LIN_COL(data)) + + if (ch < K_BASE) { + LIN_ICHAR(data) = LIN_ICHAR(data) + 1 + LIN_COL(data) = LIN_COL(data) + 1 + ic = LIN_ICHAR(data) + + if (str[ic] == EOS) { + if (ic > maxch) { + done = true + LIN_LAST(data) = EOS + } else { + str[ic] = ch + str[ic+1] = EOS + call waddstr (win, str[ic]) + } + } else { + nc = strlen (str) + if (nc >= maxch) { + done = true + LIN_LAST(data) = EOS + } else { + do jc = nc+1, ic, -1 + str[jc+1] = str[jc] + + str[ic] = ch + call winsch (win, str[ic]) + } + } + + if (ch == '\r') { + done = true + LIN_LAST(data) = '\n' + } + + } else { + ic = LIN_ICHAR(data) + switch (ch) { + case K_RIGHT: # Move right one column + if (str[ic] == EOS) { + done = true + LIN_LAST(data) = EOS + } else { + LIN_ICHAR(data) = LIN_ICHAR(data) + 1 + LIN_COL(data) = LIN_COL(data) + 1 + call wmove (win, LIN_ROW(data), LIN_COL(data)) + } + + case K_LEFT: # Move left one column + if (ic == 1) { + done = true + LIN_LAST(data) = EOS + } else { + LIN_ICHAR(data) = LIN_ICHAR(data) - 1 + LIN_COL(data) = LIN_COL(data) - 1 + call wmove (win, LIN_ROW(data), LIN_COL(data)) + } + + case K_BOL: # Move to first column in line + if (ic > 1) { + LIN_ICHAR(data) = 1 + LIN_COL(data) = LIN_COL(data) - ic + 1 + call wmove (win, LIN_ROW(data), LIN_COL(data)) + } + + case K_EOL: # Move to last column in line + if (str[ic] != EOS) { + LIN_ICHAR(data) = strlen (str) + 1 + LIN_COL(data) = LIN_COL(data) + LIN_ICHAR(data) - ic + call wmove (win, LIN_ROW(data), LIN_COL(data)) + } + + case K_DEL: # Delete character underneath cursor + if (str[ic] != EOS) { + while (str[ic] != EOS) { + str[ic] = str[ic+1] + ic = ic + 1 + } + + call wdelch (win) + } + + case K_BS: # Delete character to left of cursor + if (ic > 1) { + LIN_ICHAR(data) = LIN_ICHAR(data) - 1 + LIN_COL(data) = LIN_COL(data) - 1 + + ic = ic - 1 + while (str[ic] != EOS) { + str[ic] = str[ic+1] + ic = ic + 1 + } + + call wmove (win, LIN_ROW(data), LIN_COL(data)) + call wdelch (win) + } + + case K_DWORD: # Delete entire line + if (str[1] != EOS) { + LIN_ICHAR(data) = 1 + LIN_COL(data) = LIN_COL(data) - ic + 1 + + for (ic = 1; str[ic] != EOS; ic = ic + 1) + str[ic] = ' ' + call addstr (win, str) + str[1] = EOS + } + + default: + done = true + LIN_LAST(data) = ch + } + } +end diff --git a/pkg/utilities/nttools/tedit/display/forms/mkpkg b/pkg/utilities/nttools/tedit/display/forms/mkpkg new file mode 100644 index 00000000..e23071d5 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/mkpkg @@ -0,0 +1,19 @@ +# Update the display library. +# Author: B.Simon 01-APR-91 + +$checkout libpkg.a ../../ +$update libpkg.a +$checkin libpkg.a ../../ +$exit + +libpkg.a: + fmbegin.x "forms.com" + fmcheck.x + fmend.x + fmhelp.x "../curses.h" "forms.com" + fmgetform.x "formfn.h" + fmmkform.x "formfn.h" + fmprompt.x + fmredraw.x "formfn.h" + formfn.x "../curses.h" "formfn.h" + ; diff --git a/pkg/utilities/nttools/tedit/display/forms/promptfn.h b/pkg/utilities/nttools/tedit/display/forms/promptfn.h new file mode 100644 index 00000000..48aba6b4 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/promptfn.h @@ -0,0 +1,7 @@ +# PROMPTFN.H -- Data structure associated with promptfn() + +define LEN_PRSTRUCT 3 + +define PR_START Memi[$1] # Start flag +define PR_ROW Memi[$1+1] # Cursor row +define PR_COL Memi[$1+2] # Cursor column diff --git a/pkg/utilities/nttools/tedit/display/forms/promptfn.x b/pkg/utilities/nttools/tedit/display/forms/promptfn.x new file mode 100644 index 00000000..c270aabb --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/forms/promptfn.x @@ -0,0 +1,134 @@ +include "../curses.h" +include "promptfn.h" + +# PROMPTFN -- Function that processes the prompt input + +procedure promptfn (win, ch, maxch, str, data, done) + +int win # i: Window descriptor +int ch # i: Keyboard character +int maxch # i: Maximum line length +char str[ARB] # io: String containing line +pointer data # io: Line data structure +bool done # o: Flag indicating line is done +#-- +int nrows, ncols, ic, jc, nc +int strlen() + +begin + # Check for carriage return + + if (ch == '\r') { + done = true + return + } else { + done = false + } + + # Initialize data structure on first pass through + + if (PR_START(data) == YES) { + call wdimen (win, nrows, ncols) + if (nrows == 1) + call werase (win) + + PR_START(data) = NO + PR_ROW(data) = min (2, nrows) + PR_COL(data) = 1 + } + + if (ch < K_BASE) { + ic = PR_COL(data) + + if (str[ic] == EOS) { + if (ic <= maxch) { + str[ic] = ch + str[ic+1] = EOS + call waddstr (win, str[ic]) + } + } else { + nc = strlen (str) + if (nc < maxch) { + do jc = nc+1, ic, -1 + str[jc+1] = str[jc] + + str[ic] = ch + call winsch (win, str[ic]) + } + } + PR_COL(data) = PR_COL(data) + 1 + + } else { + ic = PR_COL(data) + switch (ch) { + case K_RIGHT: # Move right one column + if (str[ic] != EOS) { + PR_COL(data) = PR_COL(data) + 1 + call wmove (win, PR_ROW(data), PR_COL(data)) + } + + case K_LEFT: # Move left one column + if (ic != 1) { + PR_COL(data) = PR_COL(data) - 1 + call wmove (win, PR_ROW(data), PR_COL(data)) + } + + case K_BOL: # Move to first column in line + if (ic > 1) { + PR_COL(data) = 1 + call wmove (win, PR_ROW(data), PR_COL(data)) + } + + case K_EOL: # Move to last column in line + if (str[ic] != EOS) { + PR_COL(data) = strlen (str) + 1 + call wmove (win, PR_ROW(data), PR_COL(data)) + } + + case K_DEL: # Delete character underneath cursor + if (str[ic] != EOS) { + while (str[ic] != EOS) { + str[ic] = str[ic+1] + ic = ic + 1 + } + + call wdelch (win) + } + + case K_BS: # Delete character to left of cursor + if (ic > 1) { + PR_COL(data) = PR_COL(data) - 1 + + ic = ic - 1 + while (str[ic] != EOS) { + str[ic] = str[ic+1] + ic = ic + 1 + } + + call wmove (win, PR_ROW(data), PR_COL(data)) + call wdelch (win) + } + + case K_DWORD: # Delete entire line + if (str[1] != EOS) { + PR_COL(data) = 1 + + for (ic = 1; str[ic] != EOS; ic = ic + 1) + str[ic] = ' ' + call addstr (win, str) + str[1] = EOS + } + + case K_HELP: # Display help screen + call fm_help + + case K_PAINT: # Redraw the screen + call clearok (STDSCR, true) + call wrefresh (STDSCR) + call wmove (win, PR_ROW(data), PR_COL(data)) + + default: + call ps_beep + } + } +end diff --git a/pkg/utilities/nttools/tedit/display/mkpkg b/pkg/utilities/nttools/tedit/display/mkpkg new file mode 100644 index 00000000..322177b4 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/mkpkg @@ -0,0 +1,14 @@ + +# Update the display library. +# Author: B.Simon 01-APR-91 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + @curses + @forms + @screen + ; diff --git a/pkg/utilities/nttools/tedit/display/screen/README b/pkg/utilities/nttools/tedit/display/screen/README new file mode 100644 index 00000000..6a29f82f --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/README @@ -0,0 +1,211 @@ +The procedures in this directory implement the lowest level of the +screen handling routines in the display library. Procedures not +described in this file are not part of the public interface and should +not be called by user programs. All the capabilities of the curses +procedures are layered on top of the procedures in this directory. +These procedures provide less functionality than the curses routines, +but can be faster, at the expense of more complications in the user +program. The procedures in this directory are portable. They are +written in SPP and they do all their I/O through the IRAF VOS. They +use the termcap and edcap files so that this library can be used with +a variety of terminals and the editing commands can be tailored to the +user's preferences. There are two sets of subroutines in this +directory. The first set is the keyboard subroutines, prefixed by the +letter "k", which read the keyboard and translate control key +sequences to a single character. The second set is the screen +sunroutines, prefixed by the letters "ps", which write to the +terminal. + +The keyboard subroutines read input from the keyboard, translating +command key sequences into a single number. The command key sequences +are read from the edcap file. This is a file located either in the +user's home directory or the dev$ directory whose name is the value of +the editor environment variable with an extension of ".ed". See the +files in the dev$ directory for an example of the file format. The +keyboard subroutines are initialized by a call to the following +subroutine: + +procedure k_begin (cmdlist) + +char cmdlist[ARB] # i: List of editing commands + +This subroutine puts the terminal in raw mode, reads the edcap file, +and sends the keyboard initialization sequence to the terminal. Its +argument is a list of command names taken from the edcap file that you +want your program to recognize. The first character in the string is a +command separator, used to separate the commands in the string. The +macro CMDSTR in defines the list of commands used by the +curses routines. The screen initialization routine, ps_begin, must be +called before k_begin is called. To terminate the keyboard interface, +call the following subroutine: + +procedure k_end () + +This procedure ends raw mode and sends the keyboard termination sequence +to the terminal. The screen termination routine, ps_end, should be +called after this routine is called. The following subroutine reads a +single character from the terminal: + +int procedure k_get () + +Command key sequences that were named in the command list passed to +k_begin are returned as a single number. The value returned by the +first command key sequence in the command list is K_BASE, the value +returned by the second sequence is K_BASE+1, and so on. The macro +K_BASE is defined in . + +The next keyboard subroutine returns a pointer to a character string +containing the help text for the keyboard commands: + +procedure k_help (text) + +pointer text # o: Help text + +The help text string is formatted as a series of command descriptions. +Each description starts with the name of the edcap command , followed +by an equals sign, followed by the ascii representation of the key +sequence which executes the command, and terminated by a newline +character.The string is formatted as a series of command descriptions. +Each description starts with the name of the edcap command , followed +by an equals sign, followed by the ascii representation of the key +sequence which executes the command, and terminated by a newline +character. + +The following routine copies one of the command descriptions from the +help text to an output string: + +procedure k_eseq (name, eseq, maxch) + +char name[ARB] # i: Name bound to command sequence +char eseq[ARB] # o: String representation of command sequence +int maxch # i: Maximum length of command sequence + +The input parameters are the name of the command sequence and the +length of the output string. The name of the sequence should be +the name passed as part of the command string to k_begin(). The output +is the ascii represntation of the escape sequence of that command. + +The screen subroutines are used to send output to the terminal. They +are based on the subroutines in Marc Rochkind's book, "Advanced C +Programs for Displays". Several conventions are followed by these +subroutines. The first is that while strings are passed as arrays of +characters, individual characters are passed as integers. The second is +that screen coordinates are passed row first, column second and that the +coordinates of the upper left corner of the screen are (1, 1). The +third is that areas on the screen are passed as rectangles, which are +represented as arrays of four elements, where the four elements are the +(top, left, bottom, right) corners of the rectangle. The initialization +and termination routines for the screen subroutines are: + +procedure ps_begin () +procedure ps_end () + +The first subroutine opens the terminal for I/O and reads the termcap +file, the second closes the terminal. The calling program get the size +of the screen by calling the subroutines: + +int procedure ps_height () +int procedure ps_width () + +These subroutines return the number of screen rows and columns, +respectively. The following subroutine flushes the output buffer: + +procedure ps_synch () + +The user will not see any output sent by these subroutine to the +terminal until this subroutine is called. To ring the terminal's bell, +call the following subroutine: + +procedure ps_beep () + +To move the cursor on the screen call the following subroutine: + +procedure ps_setcur (row, col) + +int row # i: Cursor row +int col # i: Cursor column + +To write a string to the screen call the following subroutine: + +procedure ps_write (row, col, ncols, str, att) + +int row # i: Starting row +int col # i: Starting column +int ncols # i: Number of columns to write +char str[ARB] # i: String to write +int att # i: Attribute + +The number of columns is an upper limit on the number of characters to +write, if the string is shorter than this, the actual number of +characters on the screen will be displayed. If the string does not lie +entirely on the screen, the string will be clipped at the screen boundary. +The attribute determines whether the string is printed normally or in +standout mode. The value should be set to either A_NORM or A_STANDOUT, +which is defined in display.h. To write a string where the screen +attribute may change from character to characater call the following +subroutine: + +procedure ps_wrtcells (row, col, vector, ncols) + +int row # i: Starting row +int col # i: Starting column +char vector[ARB] # i: Vector to write +int ncols # i: Number of columns to write + +The string to be written must be at least ncols long and each character +to be displayed in standout mode should have A_STANDOUT added to its +ascii code. This subroutine is used when the calling program keeps an +array whose contents corresponds to the current screen display. To fill +an area on the screen with a single character call the following +subroutine: + +procedure ps_fill (source, ch, att) + +int source[RSIZE] # i: Rectangle +int ch # i: Fill character +int att # i: Fill attribute + +This subroutine can be used to clear part or all of the screen by +setting the fill character to blank and the fill attribute to A_NORM. +The macro RSIZE is equal to 4 and is defined in display.h. To move an +area of the screen in any of the four directions call the following +subroutine: + +bool procedure ps_slide (source, dir, dist) + +int source[RSIZE] # i: Rectangle +int dir # i: Direction (from display.h) +int dist # i: Distance (> 0) + +This subroutine can be used to scroll the screen up or down, delete one +or more characters from a line, or move a line over so that a new +character can be inserted. The direction is given as one of the four +macros DIR_UP, DIR_DOWN, DIR_LEFT, and DIR_RIGHT, defined in . +This subroutine may or may not be able to move the screen, depending on +the capabilities defined in the terminal's termcap file. If the +subroutine can move the area, it returns true and if it cannot, it +returns false. In the latter case, it is the responsibility of the +calling program to redraw the affected area of the screen in order to +move the area. + +The include file display.h contains several macros the can be used to +manipulate the rectangles passed to the screen subroutines. In order to +access the elements of a rectangle the following macros can be used: + +RTOP(rect) # Top row of a rectangle +RLEFT(rect) # Left column of a rectangle +RBOT(rect) # Bottom row of a rectangle +RRIGHT(rect) # Right column of a rectangle + +The dimensions of a rectangle can be computed by the following macros: + +RWIDTH(rect) # Number of columns in a rectangle +RHEIGHT(rect) # Number of rows in a rectangle + +A program can set the elements in a rectangle with the following macros: + +RASG(newrect, top, left, bottom, right) +RCPY(newrect, oldrect) + +The first macro assigns four scalars to the elements of a rectangle and +the second macro copies the elements of one rectangle to another. diff --git a/pkg/utilities/nttools/tedit/display/screen/kbegin.x b/pkg/utilities/nttools/tedit/display/screen/kbegin.x new file mode 100644 index 00000000..0be12ab6 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/kbegin.x @@ -0,0 +1,40 @@ +include +include "../curses.h" + +# K_BEGIN -- Initialize keyboard +# +# B.Simon 23-Jan-89 Original + +procedure k_begin (cmdlist) + +char cmdlist[ARB] # i: List of editing commands +#-- +include "screen.com" + +int klen +int strlen() + +extern k_error + +begin + # NOTE: ps_begin must be called before calling this procedure + + # Put terminal in raw mode + + call fseti (ttyin, F_RAW, YES) + + # Set up error exit routine + + call onerror (k_error) + + # Set up function key table and help screen + + call k_compile (cmdlist) + + # Send initialize keypad sequence to terminal + + klen = strlen (ks) + if (klen > 0) + call ttywrite (ttyout, term, ks, klen, 1) + +end diff --git a/pkg/utilities/nttools/tedit/display/screen/kcompile.x b/pkg/utilities/nttools/tedit/display/screen/kcompile.x new file mode 100644 index 00000000..9ad162ec --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/kcompile.x @@ -0,0 +1,148 @@ +include +include "../curses.h" + +define SYNTAX 1 +define K_CMDLEN 7 + +# K_COMPILE -- Compile a file of editing key definitions (edcap) +# +# B.Simon 23-Jan-89 Original + +procedure k_compile (cmdlist) + +char cmdlist[ARB] # i: List of commands +#-- +include "screen.com" + +char sep +int ic, maxcmd, nkey, maxkey +int hlength, hwidth, hstart, hleft, fd, tag +pointer sp, label, escape, name + +bool streq() +int k_capfile(), ps_width(), fscan(), nscan(), strdic(), gstrcpy() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (label, SZ_FNAME, TY_CHAR) + call salloc (escape, SZ_FNAME, TY_CHAR) + call salloc (name, SZ_FNAME, TY_CHAR) + + # Count the number of editing commands + + maxcmd = 0 + sep = cmdlist[1] + for (ic = 1; cmdlist[ic] != EOS; ic = ic + 1) { + if (cmdlist[ic] == sep && cmdlist[ic+1] != EOS) + maxcmd = maxcmd + 1 + } + + # Allocate dynamic memory for the function key table + + nkey = 0 + maxkey = K_CMDLEN * maxcmd + call calloc (keytab, 4*maxkey, TY_INT) + + # Set up help text + + hwidth = ps_width() / 2 + hlength = maxcmd * hwidth + call calloc (htext, hlength+1, TY_CHAR) + hstart = htext + hleft = hlength + + # Add each line from the edcap file to the table of function + # key sequences and the help screen + + fd = k_capfile () + while (fscan (fd) != EOF) { + call gargwrd (Memc[label], SZ_FNAME) + call gargwrd (Memc[escape], SZ_FNAME) + call gargwrd (Memc[name], SZ_FNAME) + + # Proceess line only if all three elements of command are present + # and command is found in command list + + if (nscan () == 3) { + + if (streq (Memc[label], "EDIT_INIT")) + call k_convert (Memc[escape], ks, K_CMDLEN) + else if (streq (Memc[label], "EDIT_TERM")) + call k_convert (Memc[escape], ke, K_CMDLEN) + + tag = strdic (Memc[label], Memc[label], SZ_FNAME, cmdlist) + if (tag > 0) { + tag = tag + K_BASE - 1 + + # Add escape sequence to function key table + + call k_doline (Memc[escape], tag, maxkey, + nkey, Memi[keytab]) + + # Add label and name to help text + + if (hleft > hwidth) { + hstart = gstrcpy (Memc[label], Memc[hstart], hleft) + + hstart + + Memc[hstart] = '=' + hstart = hstart + 1 + + hstart = gstrcpy (Memc[name], Memc[hstart], hleft) + + hstart + + Memc[hstart] = '\n' + hstart = hstart + 1 + hleft = hlength - (hstart - htext) + } + } + } + } + + Memc[hstart] = EOS + call close (fd) + call sfree (sp) +end + +# K_CAPFILE -- Open the editing capabilities file (edcap) + +int procedure k_capfile () + +#-- +int fd +pointer sp, editor, edcap + +int envgets(), access(), open() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (editor, SZ_FNAME, TY_CHAR) + call salloc (edcap, SZ_FNAME, TY_CHAR) + + # Get the name of the edcap file and open it + + if (envgets ("editor", Memc[editor], SZ_FNAME) <= 0) + call error (SYNTAX, "Editor not found") + + call sprintf (Memc[edcap], SZ_FNAME, "home$%s.ed") + call pargstr (Memc[editor]) + + if (access (Memc[edcap], READ_ONLY, 0) == NO) { + + call sprintf (Memc[edcap], SZ_FNAME, "dev$%s.ed") + call pargstr (Memc[editor]) + + if (access (Memc[edcap], READ_ONLY, 0) == NO) + call error (SYNTAX, "Edcap file not found") + + } + + fd = open (Memc[edcap], READ_ONLY, TEXT_FILE) + call sfree (sp) + + return (fd) +end diff --git a/pkg/utilities/nttools/tedit/display/screen/kconvert.x b/pkg/utilities/nttools/tedit/display/screen/kconvert.x new file mode 100644 index 00000000..11e283fa --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/kconvert.x @@ -0,0 +1,61 @@ +include + +# K_CONVERT -- Convert a string with coded escape sequences to the real thing +# +# B.Simon 23-Jan-89 Original + +procedure k_convert (escstr, escseq, maxch) + +char escstr[ARB] # i: Escape sequence string +char escseq[ARB] # o: Escape key sequence +int maxch # i: Declared length of key sequence +#-- +int ic, jc, index, num + +string echars "befnrt" +string ecodes "\010\033\f\n\r\t" + +int stridx() + +begin + ic = 1 + for (jc = 1; jc <= maxch; jc = jc + 1) { + + # Exit when all characters in escape string have been processed + + if (escstr[ic] == EOS) + break + + # Convert escape sequence + + if (escstr[ic] == '\\') { + ic = ic + 1 + index = stridx (escstr[ic], echars) + if (index > 0) { + escseq[jc] = ecodes[index] + } else if (IS_DIGIT(escstr[ic])) { + for (num = 0; IS_DIGIT(escstr[ic]); ic = ic + 1) + num = 8 * num + TO_DIGIT(escstr[ic]) + ic = ic - 1 + escseq[jc] = num + } else { + escseq[jc] = escstr[ic] + } + + # Convert control sequence + + } else if (escstr[ic] == '^') { + ic = ic + 1 + escseq[jc] = mod (int(escstr[ic]), 32) + + # Copy ordinary character + + } else { + escseq[jc] = escstr[ic] + } + + ic = ic + 1 + } + + escseq[jc] = EOS +end diff --git a/pkg/utilities/nttools/tedit/display/screen/kdoline.x b/pkg/utilities/nttools/tedit/display/screen/kdoline.x new file mode 100644 index 00000000..bcdf4a72 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/kdoline.x @@ -0,0 +1,96 @@ +include + +define SYNTAX 1 +define BOUNDS 2 + +# K_DOLINE -- Add a line containing an escape sequence to the key table +# +# B.Simon 23-Jan-89 Original + +procedure k_doline (escstr, tag, maxtab, ntab, table) + +char escstr[ARB] # i: Key sequence +int tag # i: Key tag +int maxtab # i: Maximum number of entries +int ntab # io: Current number of entries +int table[4,ARB] # io: Key sequence table +#-- +int ic, link, new, old +pointer sp, escseq + +int strlen() + +string notctrl "Key sequence must begin with a control character" +string isambig "Ambiguous key sequence" +string toomany "Too many key definitions" + +begin + # Convert escape sequence + + call smark (sp) + call salloc (escseq, SZ_FNAME, TY_CHAR) + call k_convert (escstr, Memc[escseq], SZ_FNAME) + + # Don't process null sequences + + if (Memc[escseq] == EOS) + return + + # Check to see if escape sequence is valid + + if (IS_PRINT(Memc[escseq])) + call error (SYNTAX, notctrl) + + # Find first character in key sequence that is new + + ic = 0 + link = 0 + for (new = 1; new != 0; new = table[link,old]) { + old = new + if (link == 1) + ic = ic + 1 + if (Memc[escseq+ic] == table[3,old]) + link = 1 + else + link = 2 + } + + if (link == 1) { + + # Redefinition of existing sequence + + if (Memc[escseq+ic] != EOS) + call error (SYNTAX, isambig) + table[4,old] = tag + + } else { + + # New sequence + + if (Memc[escseq+ic] == EOS) + call error (SYNTAX, isambig) + + # Check for table overflow + + if (strlen (Memc[escseq+ic]) + ntab > maxtab) + call error (BOUNDS, toomany) + + # Insert remainder of key sequence in table + + table[2,old] = ntab + 1 + while (Memc[escseq+ic] != EOS) { + ntab = ntab + 1 + table[1,ntab] = ntab + 1 + table[2,ntab] = 0 + table[3,ntab] = Memc[escseq+ic] + table[4,ntab] = 0 + ic = ic + 1 + } + table[1,ntab] = 0 + table[4,ntab] = tag + + } + + call sfree (sp) + +end diff --git a/pkg/utilities/nttools/tedit/display/screen/kend.x b/pkg/utilities/nttools/tedit/display/screen/kend.x new file mode 100644 index 00000000..57130052 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/kend.x @@ -0,0 +1,49 @@ +include + +# K_END -- Terminate keyboard +# +# B.Simon 23-Jan-89 Original + +procedure k_end () + +#-- +include "screen.com" + +int klen +int strlen() + +begin + # Restore keyboard to original state and end raw mode + + if (ttyin != NULL) { + if (term != NULL) { + klen = strlen (ke) + if (klen > 0) + call ttywrite (ttyout, term, ke, klen, 1) + } + call fseti (ttyin, F_RAW, NO) + } + + # Release dynamic memory + + if (keytab != NULL) + call mfree (keytab, TY_INT) + + if (htext != NULL) + call mfree (htext, TY_CHAR) + +end + +# K_ERROR -- Procedure called on error exit + +procedure k_error (status) + +int status # i: Error status +#-- + +begin + if (status != OK) { + call k_end + call ps_end + } +end diff --git a/pkg/utilities/nttools/tedit/display/screen/kget.x b/pkg/utilities/nttools/tedit/display/screen/kget.x new file mode 100644 index 00000000..61364f9e --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/kget.x @@ -0,0 +1,96 @@ +include + +define CAN_ABORT NO +define ABORT '\003' + +# K_GET -- Read a character, translating function keys + +int procedure k_get () + +#-- +include "screen.com" + +int ch + +int first +int k_cget(), k_lookup() + +string abortmsg "Task aborted by ^C" + +begin + if (keych != EOF) { + # Check for a pushed back character, returning it if found + + ch = keych + keych = EOF + + } else { + # Check character to see if it is the start of a control sequence + # If not, return the character without searching the table + + first = k_cget () + + if (IS_PRINT(first)) + ch = first + else if ((CAN_ABORT == YES) && (first == ABORT)) + call error (1, abortmsg) + else + ch = k_lookup (first, Memi[keytab]) + } + + return (ch) + +end + +# K_LOOKUP -- Look up a function key sequence in a table + +int procedure k_lookup (first, table) + +int first # i: First character in the sequence +int table[4,ARB] # i: Table of function key sequences +#-- +include "screen.com" + +int key, new, old, link +int k_cget() + +begin + # Search the table for the control sequence + + link = 0 + key = first + + for (new = 1; new != 0; new = table[link,old]) { + old = new + if (link == 1) + key = k_cget () + if (key == table[3,old]) + link = 1 + else + link = 2 + } + + # Return the control sequence tag if the sequence was found, + # otherwise return the first unrecognized key + + if (link == 1) + key = table[4,old] + + return (key) + +end + +# K_CGET -- Read a single character from the terminal + +int procedure k_cget () + +#-- +include "screen.com" + +int ch +int and(), getci() + +begin + ch = getci (ttyin, ch) + return (and (ch, 177B)) +end diff --git a/pkg/utilities/nttools/tedit/display/screen/khelp.x b/pkg/utilities/nttools/tedit/display/screen/khelp.x new file mode 100644 index 00000000..4b075f8a --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/khelp.x @@ -0,0 +1,61 @@ +include + +# K_HELP -- Retrieve help text for function key sequences + +procedure k_help (text) + +pointer text # o: Help text +#-- +include "screen.com" + +begin + text = htext +end + +procedure k_eseq (name, eseq, maxch) + +char name[ARB] # i: Name bound to escape sequence +char eseq[ARB] # o: String representation of escape sequence +int maxch # i: Maximum length of escape sequence +#-- +include "screen.com" + +bool match, in_name +int ic +pointer ch + +begin + ic = 1 + match = true + in_name = true + + for (ch = htext; Memc[ch] != EOS; ch = ch + 1) { + if (in_name) { + if (Memc[ch] == '=') { + match = match && name[ic] == EOS + in_name = false + ic = 1 + } else if (match) { + if (Memc[ch] == name[ic]) { + ic = ic + 1 + } else { + match = false + } + } + + } else { + if (Memc[ch] == '\n') { + if (match) + break + ic = 1 + match = true + in_name = true + } else if (match && ic <= maxch) { + eseq[ic] = Memc[ch] + ic = ic + 1 + } + } + } + eseq[ic] = EOS + +end diff --git a/pkg/utilities/nttools/tedit/display/screen/kpushbk.x b/pkg/utilities/nttools/tedit/display/screen/kpushbk.x new file mode 100644 index 00000000..6e9c05c2 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/kpushbk.x @@ -0,0 +1,11 @@ +# K_PUSHBK -- Push back a single character read from the keyboard + +procedure k_pushbk (ch) + +int ch # i: character to be pushed back +#-- +include "screen.com" + +begin + keych = ch +end diff --git a/pkg/utilities/nttools/tedit/display/screen/mkpkg b/pkg/utilities/nttools/tedit/display/screen/mkpkg new file mode 100644 index 00000000..dc062ae4 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/mkpkg @@ -0,0 +1,32 @@ +# Update the display library. +# Author: B.Simon 01-APR-91 + +$checkout libpkg.a ../../ +$update libpkg.a +$checkin libpkg.a ../../ +$exit + +libpkg.a: + kbegin.x "../curses.h" "screen.com" + kcompile.x "../curses.h" "screen.com" + kconvert.x + kdoline.x + kend.x "screen.com" + kget.x "screen.com" + khelp.x "screen.com" + kpushbk.x "screen.com" + psbegin.x "screen.com" + psbeep.x + psend.x "screen.com" + psfill.x "../curses.h" "screen.com" + psheight.x "screen.com" + psintersect.x "../curses.h" + psscreen.x "screen.com" + pssendcap.x "screen.com" + pssetcur.x "screen.com" + psslide.x "../curses.h" "screen.com" + pssynch.x "screen.com" + pswidth.x "screen.com" + pswrite.x "../curses.h" "screen.com" + pswrtcells.x "../curses.h" "screen.com" + ; diff --git a/pkg/utilities/nttools/tedit/display/screen/psbeep.x b/pkg/utilities/nttools/tedit/display/screen/psbeep.x new file mode 100644 index 00000000..252991ba --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/psbeep.x @@ -0,0 +1,9 @@ +# PS_BEEP -- Sound the bell +# +# B.Simon 19-Jan-89 Original + +procedure ps_beep () + +begin + call ps_sendcap ("bl", 1) +end diff --git a/pkg/utilities/nttools/tedit/display/screen/psbegin.x b/pkg/utilities/nttools/tedit/display/screen/psbegin.x new file mode 100644 index 00000000..2bf702cf --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/psbegin.x @@ -0,0 +1,59 @@ +include +include "../curses.h" + +# PS_BEGIN -- Initialize physical screen display +# +# B.Simon 18-Jan-89 Original +# B.Simon 26-Sep-90 Updated to use screen buffer + +procedure ps_begin () + +#-- +include "screen.com" + +char ch +data ch / EOS / + +string nomove "Terminal does not support cursor movement (cm)" + +bool ttygetb() +int ttopen(), ttystati() +pointer ttyodes() + +begin + # Initialize global variables + + ks[1] = EOS + ke[1] = EOS + keych = EOF + + currow = GIANT + curcol = GIANT + + keytab = NULL + termscr = NULL + htext = NULL + + term = ttyodes ("terminal") + lines = ttystati (term, TTY_NLINES) + cols = ttystati (term, TTY_NCOLS) + + if (! ttygetb (term, "cm")) { + call ttyclose (term) + call error (1, nomove) + } + + ttyin = ttopen ("dev$tty", READ_ONLY) + ttyout = ttopen ("dev$tty", APPEND) + + # Allocate memory for screen and fill with EOS + + call malloc (termscr, lines*cols, TY_CHAR) + call amovkc (ch, Memc[termscr], lines*cols) + + # Initialize display + + call ps_sendcap ("ti", 1) + call ps_sendcap ("vs", 1) + +end diff --git a/pkg/utilities/nttools/tedit/display/screen/psend.x b/pkg/utilities/nttools/tedit/display/screen/psend.x new file mode 100644 index 00000000..1d86e6df --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/psend.x @@ -0,0 +1,48 @@ +# PS_END -- Terminate physical display package +# +# B.Simon 18-Jan-89 Original +# B.Simon 26-Sep-90 Updated to use screen buffer + +procedure ps_end() + +#-- +include "screen.com" + +char newline +data newline / '\n' / + +begin + # Restore terminal to original state and release termcap structure + + if (term != NULL) { + call ps_sendcap ("ve", 1) + call ps_sendcap ("te", 1) + + if (ttyout != NULL) { + call ttygoto (ttyout, term, 1, lines) + call putc (ttyout, newline) + } + call ttyclose (term) + term = NULL + } + + # Release screen memory + + if (termscr != NULL) { + call mfree (termscr, TY_CHAR) + termscr = NULL + } + + # Close terminal descriptor + + if (ttyin != NULL) { + call close (ttyin) + ttyin = NULL + } + + if (ttyout != NULL) { + call close (ttyout) + ttyout = NULL + } + +end diff --git a/pkg/utilities/nttools/tedit/display/screen/psfill.x b/pkg/utilities/nttools/tedit/display/screen/psfill.x new file mode 100644 index 00000000..2ceee221 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/psfill.x @@ -0,0 +1,135 @@ +include +include "../curses.h" + +# PS_FILL -- Fill a rectangle with a single character and attribute +# +# B.Simon 19-Jan-89 Original +# B.Simon 26-Sep-90 Updated to use screen buffer +# B.Simon 31-Oct-90 Changed to skip correct lines + +procedure ps_fill (source, ch, att) + +int source[RSIZE] # i: Rectangle +int ch # i: Fill character +int att # i: Fill attribute +#-- +include "screen.com" + +bool canclear, bufflag +char blank, fill, cell +int dest[RSIZE] +int ncols, nrows, irow, icol +pointer sp, buf, scr + +data blank / ' ' / + +bool ps_intersect(), ttygetb() +pointer ps_screen() + +begin + # Clip the rectangle to the screen boundary + # If the rectangle is entirely off the screen, return + + if (! ps_intersect (source, lines, cols, dest)) + return + + + # Check for the special cases: + # Clear entire screen (cl) and clear to end of screen (cd) + + canclear = (ch == ' ' && att == A_NORM) + ncols = RWIDTH(dest) + nrows = RHEIGHT(dest) + + if (canclear && ncols == cols && nrows == lines) { + if (ttygetb (term, "cl")) { + call ps_updcur (1, 1) + call ps_sendcap ("cl", nrows) + call amovkc (blank, Memc[termscr], lines*cols) + return + } + } + + if (canclear && ncols == cols && RBOT(dest) == lines) { + if (ttygetb (term, "cd")) { + call ps_setcur (RTOP(dest), 1) + call ps_sendcap ("cd", nrows) + scr = ps_screen (RTOP(dest), 1) + call amovkc (blank, Memc[scr], nrows*cols) + return + } + } + + # Write the rectangle a line at a time + + call smark (sp) + call salloc (buf, cols, TY_CHAR) + + if (IS_PRINT(ch)) + fill = ch + else + fill = blank + + cell = fill + att + bufflag = false + + canclear = canclear && ttygetb (term, "ce") + + do irow = RTOP(dest), RBOT(dest) { + + # Check to see if line is already correct + # If so, skip to the next line + + scr = ps_screen (irow, RLEFT(dest)) + + for (icol = 1; icol <= ncols; icol = icol + 1) { + if (Memc[scr+icol-1] != cell) + break + } + + if (icol > ncols) + next + + # Move cursor to beginning of line and set attribute + + call ps_setcur (irow, RLEFT(dest)) + + if (att != A_NORM) + call ps_sendcap ("so", 1) + + # Special case: clear to end of line + + if (canclear && RRIGHT(dest) == cols) { + call ps_sendcap ("ce", 1) + call amovkc (blank, Memc[scr], ncols) + + } else { + + # Fill buffer with character and write to terminal + + if (! bufflag) { + bufflag = true + call amovkc (fill, Memc[buf], ncols) + } + + # Don't write to lower right corner if screen will scroll + + if (irow == lines && RRIGHT(dest) == cols) { + if (ttygetb (term, "am")) + ncols = ncols - 1 + } + + call write (ttyout, Memc[buf], ncols) + call amovkc (cell, Memc[scr], ncols) + call ps_updcur (irow, RRIGHT(dest) + 1) + } + + # Set attribute back to normal + + if (att != A_NORM) + call ps_sendcap ("se", 1) + + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tedit/display/screen/psheight.x b/pkg/utilities/nttools/tedit/display/screen/psheight.x new file mode 100644 index 00000000..8350e773 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/psheight.x @@ -0,0 +1,12 @@ +# PS_HEIGHT -- Get height of physical screen +# +# B.Simon 18-Jan-89 Original + +int procedure ps_height () + +#-- +include "screen.com" + +begin + return (lines) +end diff --git a/pkg/utilities/nttools/tedit/display/screen/psintersect.x b/pkg/utilities/nttools/tedit/display/screen/psintersect.x new file mode 100644 index 00000000..93c11f0f --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/psintersect.x @@ -0,0 +1,27 @@ +include "../curses.h" + +# PS_INTERSECT -- Intersection between two rectangles +# +# B.Simon 18-Jan-89 Original + +bool procedure ps_intersect (source, maxrow, maxcol, dest) + +int source[RSIZE] # i: Source rectangle +int maxrow # i: Max row of clipping rectangle +int maxcol # i: Max column of clipping rectangle +int dest[RSIZE] # o: Destination rectangle +#-- + +begin + # Clip source rectangle to (1,1) and (maxrow,maxcol) + + RTOP(dest) = max (1, RTOP(source)) + RLEFT(dest) = max (1, RLEFT(source)) + RBOT(dest) = min (maxrow, RBOT(source)) + RRIGHT(dest) = min (maxcol, RRIGHT(source)) + + # Return true if intersection is non-empty + + return (RTOP(dest) <= RBOT(dest) && RLEFT(dest) <= RRIGHT(dest)) +end + diff --git a/pkg/utilities/nttools/tedit/display/screen/psscreen.x b/pkg/utilities/nttools/tedit/display/screen/psscreen.x new file mode 100644 index 00000000..afdd7b8d --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/psscreen.x @@ -0,0 +1,14 @@ +# PS_SCREEN -- Return a pointer to a given character on the screen +# +# B.Simon 28-Sep-90 Original + +pointer procedure ps_screen (row, col) + +int row # i: Screen line +int col # i: Screen column +#-- +include "screen.com" + +begin + return (termscr+cols*(row-1)+(col-1)) +end diff --git a/pkg/utilities/nttools/tedit/display/screen/pssendcap.x b/pkg/utilities/nttools/tedit/display/screen/pssendcap.x new file mode 100644 index 00000000..295a6cff --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/pssendcap.x @@ -0,0 +1,74 @@ +# PS_SENDCAP -- Send a termcap command to the terminal +# +# B.Simon 18-Jan-89 Original + +procedure ps_sendcap (cap, affcnt) + +char cap[ARB] # i: Termcap capability name +int affcnt # i: Number of lines affected by the command +#-- +include "screen.com" + +int nchar +pointer sp, capstr + +int ttygets() + +begin + call smark (sp) + call salloc (capstr, SZ_FNAME, TY_CHAR) + + # Retrieve the termcap capability string given its name + # If it is found, write it to the terminal + + nchar = ttygets (term, cap, Memc[capstr], SZ_FNAME) + if (nchar > 0) { + call ttywrite (ttyout, term, Memc[capstr], nchar, affcnt) + ## call ps_debugcap (cap, Memc[capstr], nchar) + } + + call sfree (sp) +end + +# PS_DEBUGCAP -- Print a termcap string for debugging purposes + +procedure ps_debugcap (capname, capstr, nchar) + +char capname[ARB] # i: Termcap capability name +char capstr[ARB] # i: Termcap capability string +int nchar # i: Number of characters in string +#-- +include "screen.com" + +char ch +int ic, jc +pointer sp, out + +begin + # Allocate memory for strings + + call smark (sp) + call salloc (out, SZ_LINE, TY_CHAR) + + jc = 0 + do ic = 1, nchar { + ch = capstr[ic] + if (ch < ' ') { + Memc[out+jc] = '^' + jc = jc + 1 + ch = ch + '@' + } + Memc[out+jc] = ch + jc = jc + 1 + } + Memc[out+jc] = EOS + + # Write string to STDOUT and flush + + call fprintf (ttyout, "%s = %s\n") + call pargstr (capname) + call pargstr (Memc[out]) + call flush (ttyout) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tedit/display/screen/pssetcur.x b/pkg/utilities/nttools/tedit/display/screen/pssetcur.x new file mode 100644 index 00000000..a6954da3 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/pssetcur.x @@ -0,0 +1,117 @@ +define ABSOLUTE YES # disable relative cursor motion if YES + +# PS_SETCUR -- Set the cursor position +# +# B.Simon 19-Jan-89 Original +# B.Simon 19-Dec-90 Rewritten to speed cursor motion +# B.Simon 10-Apr-91 Add switch to disable relative motion + +procedure ps_setcur (row, col) + +int row # i: Cursor row +int col # i: Cursor column +#-- +include "screen.com" + +bool moved +int newrow, newcol, dr, dc + +bool ttygetb() + +begin + newrow = min (lines, max (1, row)) + newcol = min (cols, max (1, col)) + + moved = true + dr = newrow - currow + dc = newcol - curcol + + if (ABSOLUTE == YES) { + if (dr != 0 || dc != 0) + moved = false + + } else if (dr == 0) { + if (dc == 0) { # no move + return + + } else if (dc == 1) { # move right by one + if (ttygetb (term, "nd")) + call ps_sendcap ("nd", 1) + else + moved = false + + } else if (dc == -1) { # move left by one + if (ttygetb (term, "le")) + call ps_sendcap ("le", 1) + else + moved = false + + } else { + moved = false + } + + } else if (dr == 1) { + if (dc == 0) { # move down by one + if (ttygetb (term, "do")) + call ps_sendcap ("do", 1) + else + moved = false + + } else { + moved = false + } + + } else if (dr == -1) { + if (dc == 0) { # move up by one + if (ttygetb (term, "up")) + call ps_sendcap ("up", 1) + else + moved = false + } else { + moved = false + } + + } else { + moved = false + } + + if (! moved) # must use absolute move + call ttygoto (ttyout, term, newcol, newrow) + + # Update current cursor position + + currow = newrow + curcol = newcol +end + +# PS_UPDCUR -- Update the cursor position + +procedure ps_updcur (row, col) + +int row # i: New cursor row +int col # i: New cursor column +#-- +include "screen.com" + +bool ttygetb() + +begin + if (row >= lines) { + currow = lines + } else { + currow = row + } + + if (col >= cols) { + if (ttygetb (term, "am")) { + currow = min (row + 1, lines) + curcol = 1 + } else { + curcol = cols + } + + } else { + curcol = col + } + +end diff --git a/pkg/utilities/nttools/tedit/display/screen/psslide.x b/pkg/utilities/nttools/tedit/display/screen/psslide.x new file mode 100644 index 00000000..5ad0bc5d --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/psslide.x @@ -0,0 +1,182 @@ +include "../curses.h" + +# PS_SLIDE -- Slide a rectangle on the screen +# +# B.Simon 19-Jan-89 Original +# B.Simon 26-Sep-90 Updated to use screen buffer +# B.Simon 22-Mar-91 Fix error in left & right slides + +bool procedure ps_slide (source, dir, dist) + +int source[RSIZE] # i: Rectangle +int dir # i: Direction (from curses.h) +int dist # i: Distance (> 0) +#-- +include "screen.com" + +char blank +int dest[RSIZE] +int nrows, ncols, irow, icol +pointer oldscr, newscr, linscr + +data blank / ' ' / + +bool ps_intersect(), ttygetb() +pointer ps_screen() + +begin + if (! ps_intersect (source, lines, cols, dest)) + return (true) + + ncols = RWIDTH(dest) + nrows = RHEIGHT(dest) + + switch (dir) { + case DIR_UP: + if (RLEFT(dest) != 1 || RRIGHT(dest) != cols) + return (false) + if ( !(ttygetb (term, "al") && ttygetb (term, "dl"))) + return (false) + + call ps_setcur (max (1, RTOP(dest)-dist), 1) + do irow = 1, dist + call ps_sendcap ("dl", lines - RTOP(dest) + dist) + + if (RBOT(dest) < lines) { + call ps_setcur (RBOT(dest) + 1, 1) + do irow = 1, dist + call ps_sendcap ("al", lines - RBOT(dest)) + } + + oldscr = ps_screen (RTOP(dest), 1) + newscr = ps_screen (RTOP(dest)-dist, 1) + do irow = 1, nrows-dist { + if (newscr >= termscr) + call amovc (Memc[oldscr], Memc[newscr], ncols) + oldscr = oldscr + cols + newscr = newscr + cols + } + do irow = 1, dist { + if (newscr < (termscr + lines * cols)) + call amovkc (blank, Memc[newscr], ncols) + newscr = newscr + cols + } + + case DIR_DOWN: + if (RLEFT(dest) != 1 || RRIGHT(dest) != cols) + return (false) + if ( !(ttygetb (term, "al") && ttygetb (term, "dl"))) + return (false) + + call ps_setcur (min (lines, RBOT(dest)+1), 1) + do irow = 1, dist + call ps_sendcap ("dl", lines - RBOT(dest)) + + call ps_setcur (RTOP(dest), 1) + do irow = 1, dist + call ps_sendcap ("al", lines - RTOP(dest)) + + oldscr = ps_screen (RBOT(dest), 1) + newscr = ps_screen (RBOT(dest)+dist, 1) + do irow = 1, nrows-dist { + if (newscr < (termscr + lines * cols)) + call amovc (Memc[oldscr], Memc[newscr], ncols) + oldscr = oldscr - cols + newscr = newscr - cols + } + do irow = 1, dist { + if (newscr >= termscr) + call amovkc (blank, Memc[newscr], ncols) + newscr = newscr - cols + } + + case DIR_LEFT: + if (! ((ttygetb (term, "ic") || ttygetb (term, "im")) && + ttygetb (term, "dc"))) + return (false) + + do irow = RTOP(dest), RBOT(dest) { + + call ps_setcur (irow, max (1, RLEFT(dest)-dist)) + call ps_sendcap ("dm", 1) + do icol = 1, dist + call ps_sendcap ("dc", 1) + call ps_sendcap ("ed", 1) + + if (RRIGHT(dest) < cols) { + call ps_setcur (irow, RRIGHT(dest) - dist + 1) + call ps_sendcap ("im", 1) + do icol = 1, dist { + call ps_sendcap ("ic", 1) + call ps_sendcap ("ip", 1) + call putc (ttyout, blank) + } + call ps_sendcap ("ei", 1) + call ps_updcur (irow, RRIGHT(dest) + 1) + } + + linscr = ps_screen (irow,1) + oldscr = ps_screen (irow,RLEFT(dest)) + newscr = oldscr - dist + + do icol = 1, ncols-dist+1 { + if (newscr >= linscr) + Memc[newscr] = Memc[oldscr] + oldscr = oldscr + 1 + newscr = newscr + 1 + } + + do icol = 1, dist { + if (newscr < linscr + cols) + Memc[newscr] = blank + newscr = newscr + 1 + } + } + case DIR_RIGHT: + if (! ((ttygetb (term, "ic") || ttygetb (term, "im")) && + ttygetb (term, "dc"))) + return (false) + + do irow = RTOP(dest), RBOT(dest) { + + if (RRIGHT(dest) < cols - 1) { + call ps_setcur (irow, RRIGHT(dest) + 1) + call ps_sendcap ("dm", 1) + do icol = 1, dist + call ps_sendcap ("dc", 1) + call ps_sendcap ("ed", 1) + } + + call ps_setcur (irow, RLEFT(dest)) + call ps_sendcap ("im", 1) + do icol = 1, dist { + call ps_sendcap ("ic", 1) + call ps_sendcap ("ip", 1) + call putc (ttyout, blank) + } + call ps_sendcap ("ei", 1) + call ps_updcur (irow, RLEFT(dest) + dist) + + linscr = ps_screen (irow,1) + oldscr = ps_screen (irow,RRIGHT(dest)) + newscr = oldscr + dist + + do icol = 1, ncols-dist+1 { + if (newscr < linscr + cols) + Memc[newscr] = Memc[oldscr] + oldscr = oldscr - 1 + newscr = newscr - 1 + } + + do icol = 1, dist { + if (newscr >= linscr) + Memc[newscr] = blank + newscr = newscr - 1 + } + } + default: + return (false) + } + + return (true) +end diff --git a/pkg/utilities/nttools/tedit/display/screen/pssynch.x b/pkg/utilities/nttools/tedit/display/screen/pssynch.x new file mode 100644 index 00000000..a91474c8 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/pssynch.x @@ -0,0 +1,12 @@ +# PS_SYNCH -- Bring screen up to date +# +# B.Simon 18-Jan-89 Original + +procedure ps_synch () + +#-- +include "screen.com" + +begin + call flush (ttyout) +end diff --git a/pkg/utilities/nttools/tedit/display/screen/pswidth.x b/pkg/utilities/nttools/tedit/display/screen/pswidth.x new file mode 100644 index 00000000..d06a190c --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/pswidth.x @@ -0,0 +1,12 @@ +# PS_WIDTH -- Get width of physical screen +# +# B.Simon 18-Jan-89 Original + +int procedure ps_width () + +#-- +include "screen.com" + +begin + return (cols) +end diff --git a/pkg/utilities/nttools/tedit/display/screen/pswrite.x b/pkg/utilities/nttools/tedit/display/screen/pswrite.x new file mode 100644 index 00000000..ea8de0af --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/pswrite.x @@ -0,0 +1,79 @@ +include +include "../curses.h" + +# PS_WRITE -- Write a string on the physical screen +# +# B.Simon 18-Jan-89 Original +# B.Simon 26-Sep-90 Updated to use screen buffer + +procedure ps_write (row, col, ncols, str, att) + +int row # i: Starting row +int col # i: Starting column +int ncols # i: Number of columns to write +char str[ARB] # i: String to write +int att # i: Attribute +#-- +include "screen.com" + +char blank +int colstart, colend, idxstart, idxend, idx +pointer scr + +data blank / ' ' / + +bool ttygetb() +int strlen() +pointer ps_screen() + +begin + # Don't try to print if string is entirely off the screen + + if (row < 1 || row > lines || col > cols) + return + + # Compute the portion of the string that is on the screen + + colstart = max (col, 1) + colend = min (ncols, strlen(str)) + col - 1 + colend = min (colend, cols) + + if (colend == cols && row == lines) { + if (ttygetb (term, "am")) + colend = colend - 1 + } + + if (colend < colstart) + return + + idxstart = colstart - col + 1 + idxend = colend - col + 1 + + # Move the cursor to the position of the first printed character + + call ps_setcur (row, colstart) + + # Print the string with the proper attribute + # All non-printing characters are printed as blanks + + if (att != A_NORM) + call ps_sendcap ("so", 1) + + scr = ps_screen (row, colstart) + do idx = idxstart, idxend { + if (IS_PRINT(str[idx])) { + call putc (ttyout, str[idx]) + Memc[scr] = str[idx] + att + } else { + call putc (ttyout, blank) + Memc[scr] = blank + att + } + scr = scr + 1 + } + + if (att != A_NORM) + call ps_sendcap ("se", 1) + + call ps_updcur (row, colend + 1) + +end diff --git a/pkg/utilities/nttools/tedit/display/screen/pswrtcells.x b/pkg/utilities/nttools/tedit/display/screen/pswrtcells.x new file mode 100644 index 00000000..0e080121 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/pswrtcells.x @@ -0,0 +1,114 @@ +include +include "../curses.h" + +# PS_WRTCELLS -- Write a vector of cells +# +# B.Simon 19-Jan-89 Original +# B.Simon 26-Sep-90 Updated to use screen buffer + +procedure ps_wrtcells (row, col, vector, ncols) + +int row # i: Starting row +int col # i: Starting column +char vector[ARB] # i: Vector to write +int ncols # i: Number of columns to write +#-- +include "screen.com" + +char blank, att, ch +int colstart, colend, idxstart, idxend, idx +pointer scr + +data blank / ' ' / + +bool ttygetb() +pointer ps_screen() + +begin + # Don't try to print if vector is entirely off the screen + + if (row < 1 || row > lines || col > cols) + return + + # Compute the portion of the vector that is on the screen + + colstart = max (col, 1) + colend = min (ncols + col - 1, cols) + + if (colend == cols && row == lines) { + if (ttygetb (term, "am")) + colend = colend - 1 + } + + idxstart = colstart - col + 1 + idxend = colend - col + 1 + + # Adjust string start and end so that portions that + # duplicate the current screen contents are not printed + + scr = ps_screen (row, colend) + while (idxend >= idxstart) { + if (vector[idxend] != Memc[scr]) + break + + colend = colend - 1 + idxend = idxend - 1 + scr = scr - 1 + } + + scr = ps_screen (row, colstart) + while (idxstart <= idxend) { + if (vector[idxstart] != Memc[scr]) + break + + colstart = colstart + 1 + idxstart = idxstart + 1 + scr = scr + 1 + } + + if (colend < colstart) + return + + # Move the cursor to the position of the first printed character + + call ps_setcur (row, colstart) + + # Print the vector + + att = 0 + do idx = idxstart, idxend { + + # Set the proper attribute + + if (vector[idx] < A_STANDOUT) { + ch = vector[idx] + if (att != 0) { + att = 0 + call ps_sendcap ("se", 1) + } + } else { + ch = vector[idx] - A_STANDOUT + if (att == 0) { + att = vector[idx] - ch + call ps_sendcap ("so", 1) + } + } + + # Print non-printing character as blank + + if (IS_PRINT(ch)) { + call putc (ttyout, ch) + Memc[scr] = ch + att + } else { + call putc (ttyout, blank) + Memc[scr] = blank + att + } + scr = scr + 1 + } + + if (att != 0) + call ps_sendcap ("se", 1) + + call ps_updcur (row, colend + 1) + +end diff --git a/pkg/utilities/nttools/tedit/display/screen/screen.com b/pkg/utilities/nttools/tedit/display/screen/screen.com new file mode 100644 index 00000000..5a13cd02 --- /dev/null +++ b/pkg/utilities/nttools/tedit/display/screen/screen.com @@ -0,0 +1,18 @@ +# SCREEN.COM -- Global variables used by the screen routines + +pointer keytab # Table of function key sequences +pointer termscr # Copy of terminal screen contents +pointer htext # Function key help text +pointer term # The termcap data structure +int ttyin # Input file descriptor for the terminal +int ttyout # Output file descriptor for the terminal +int lines # The number of lines on the screen +int cols # The number of columns on the screen +int currow # Cursor row +int curcol # Cursor column +int keych # Pushed back keyboard character +char ks[7] # Initialize keypad sequence +char ke[7] # Terminate keypad sequence + +common /screen/ keytab, termscr, htext, ttyin, ttyout, term, + lines, cols, currow, curcol, keych, ks, ke diff --git a/pkg/utilities/nttools/tedit/edit.x b/pkg/utilities/nttools/tedit/edit.x new file mode 100644 index 00000000..8fe14a87 --- /dev/null +++ b/pkg/utilities/nttools/tedit/edit.x @@ -0,0 +1,70 @@ +include "command.h" + +# EDIT -- Main procedure of table editor + +procedure edit (table, columns, silent, rdonly, inplace) + +char table[ARB] # i: SDAS table name +char columns[ARB] # i: list of columns to edit +bool silent # i: don't ring bell when error occurs +bool rdonly # i: edit table read only +bool inplace # i: edit table in place +#-- +int nargs, code +pointer sp, scr, command, arglist + +begin + call smark (sp) + call salloc (command, SZ_LINE, TY_CHAR) + call salloc (arglist, SZ_LINE, TY_CHAR) + + call init_cmd (silent) + call init_screen (table, columns, rdonly, inplace, scr) + call help_prompt (scr, NO) + + repeat { + call edit_screen (scr) + call read_prompt ("Command:", Memc[command], SZ_LINE) + call parse_cmd (Memc[command], code, nargs, Memc[arglist], SZ_LINE) + + if (nargs > 0) { + switch (code) { + case TED_ADD: + call add_cmd (scr, nargs, Memc[arglist]) + case TED_COPY: + call copy_cmd (scr, nargs, Memc[arglist]) + case TED_DELETE: + call delete_cmd (scr, nargs, Memc[arglist]) + case TED_EXIT: + call exit_cmd (scr, nargs, Memc[arglist]) + break + case TED_FIND: + call find_cmd (scr, nargs, Memc[arglist]) + case TED_GOTO: + call goto_cmd (scr, nargs, Memc[arglist]) + case TED_HELP: + call help_cmd (scr, nargs, Memc[arglist]) + case TED_INSERT: + call insert_cmd (scr, nargs, Memc[arglist]) + case TED_LOWER: + call lower_cmd (scr, nargs, Memc[arglist]) + case TED_NEXT: + call next_cmd (scr, nargs, Memc[arglist]) + case TED_QUIT: + call quit_cmd (scr, nargs, Memc[arglist]) + break + case TED_SET: + call set_cmd (scr, nargs, Memc[arglist]) + case TED_SUBSTITUTE: + call sub_cmd (scr, nargs, Memc[arglist]) + case TED_UPPER: + call upper_cmd (scr, nargs, Memc[arglist]) + default: + call help_prompt (scr, YES) + } + } + } + + call end_screen + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tedit/field.h b/pkg/utilities/nttools/tedit/field.h new file mode 100644 index 00000000..4a74799c --- /dev/null +++ b/pkg/utilities/nttools/tedit/field.h @@ -0,0 +1,23 @@ +# FIELD.H -- Tedit field descriptor + +define TED_FLDLEN 11 # field descriptor length + +define TED_FSCREEN Memi[$1] # screen associated with field +define TED_RDOFLD Memi[$1+1] # is this a read only field? +define TED_PGSIZE Memi[$1+2] # number of rows on screen +define TED_LSTROW Memi[$1+3] # last row in table +define TED_LSTCOL Memi[$1+4] # last column in table +define TED_NXTROW Memi[$1+5] # next row to edit +define TED_NXTCOL Memi[$1+6] # next column to edit +define TED_DIRECT Memi[$1+7] # direction of motion +define TED_FINDEX Memi[$1+8] # column index +define TED_MRKFLD Memi[$1+9] # has this field been changed? +define TED_COMMAND Memi[$1+10] # has command key been pressed? + +define SZ_FIELD 512 # Maximum length of a single field + +# The following are the legal alignments (used by align_field and move_field) + +define LEFT 1 +define CENTER 2 +define RIGHT 3 diff --git a/pkg/utilities/nttools/tedit/field.x b/pkg/utilities/nttools/tedit/field.x new file mode 100644 index 00000000..5fecad11 --- /dev/null +++ b/pkg/utilities/nttools/tedit/field.x @@ -0,0 +1,749 @@ +include +include +include +include +include "display/curses.h" +include "screen.h" +include "table.h" +include "field.h" + +# FIELD -- Procedures which manipulate a single field (table element) + +# ADD_FIELD -- Add a new field to the table and screen + +procedure add_field (scr, tabrow, tabcol) + +pointer scr # u: screen descriptor +int tabrow # i: new table row +int tabcol # i: new table column +#-- +char blank +int win, nrows, ncols, row, col, irow, icol, junk, hitab, ic +pointer tab, tptr, sp, line, temp + +data blank / ' ' / + +int tbpsta(), itoc() + +begin + # Get window and table pointers from screen descriptor + + win = TED_WINDOW(scr) + tab = TED_TABLE(scr) + tptr = TED_TABPTR(tab) + + # Get dimensions of window and table + + call wdimen (win, nrows, ncols) + call pos_field (scr, 1, row, col) + hitab = tbpsta (tptr, TBL_NROWS) + + # Add new row to table + + call tbtwer (tptr, tabrow) + TED_DIRTY(tab) = YES + + # Update current row and column + + TED_CURROW(scr) = tabrow + TED_CURCOL(scr) = tabcol + + # If new row is off screen, redraw screen + + if (row >= nrows || col >= ncols) { + call move_screen (scr, LEFT, YES) + return + } + + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (line, ncols+1,TY_CHAR) + call salloc (temp, SZ_LINE, TY_CHAR) + + # Copy table elements to text line + # and write the line on the screen + + call wmove (win, row+1, 1) + do irow = hitab+1, tabrow { + junk = itoc (irow, Memc[temp], SZ_LINE) + call align_field (RIGHT, blank, Memc[temp], + Memc[line], TED_LABWIDTH(tab)) + + ic = TED_LABWIDTH(tab) + do icol = TED_LOCOL(scr), TED_HICOL(scr) { + Memc[line+ic] = ' ' + ic = ic + 1 + + call tbegtt (tptr, TED_COLPTR(tab,icol), irow, + Memc[temp], SZ_LINE) + + call align_field (LEFT, blank, Memc[temp], Memc[line+ic], + TED_COLLEN(tab,icol)) + ic = ic + TED_COLLEN(tab,icol) + } + + Memc[line+ic] = '\n' + Memc[line+ic+1] = EOS + call waddstr (win, Memc[line]) + } + + # Move cursor to current field and refresh window + + TED_HIROW(scr) = tabrow + call move_field (scr) + + call wrefresh (win) + call sfree (sp) + +end + +# ALIGN_FIELD -- Align a string within a larger field + +procedure align_field (align, fill, instr, outstr, outlen) + +int align # i: alignment of output string +char fill # i: fill character +char instr[ARB] # i: input string +char outstr[ARB] # o: output string +int outlen # i: length of output string +#-- +int ibeg, iend, inlen, jbeg, jend, ic, jc, kc + +begin + # Get the first and last characters in the string + # which are not fill characters + + ibeg = 0 + iend = 0 + for (ic = 1; instr[ic] != EOS; ic = ic + 1) { + if (instr[ic] != fill) { + if (ibeg == 0) + ibeg = ic + iend = ic + } + } + ibeg = max (ibeg, 1) + inlen = (iend - ibeg) + 1 + + # Check the length of the input string to see + # if the alignment problem is trivial + + if (inlen >= outlen) { + call strcpy (instr[ibeg], outstr, outlen) + return + } + + # Calculate the number of fill characters to add at + # the beginning and end of the string + + switch (align) { + case LEFT: + jbeg = 0 + jend = outlen - inlen + + case CENTER: + jbeg = (outlen - inlen) / 2 + jend = outlen - inlen - jbeg + + case RIGHT: + jbeg = outlen - inlen + jend = 0 + } + + # Create the output string + + for (jc = 1; jc <= jbeg; jc = jc + 1) + outstr[jc] = fill + + for (ic = ibeg; ic <= iend; ic = ic + 1) { + outstr[jc] = instr[ic] + jc = jc + 1 + } + + for (kc = 1; kc <= jend; kc = kc + 1) { + outstr[jc] = fill + jc = jc + 1 + } + + outstr[jc] = EOS +end + +# CHECK_FIELD -- Check string to see if it has the correct data type + +bool procedure check_field (datatype, field) + +int datatype # i: Datatype to check +char field[ARB] # i: String to be checked +#-- +bool match +double fieldval +int ic, nc, lextype, fieldtype +pointer sp, temp + +string yorn "|yes|no|" + +bool streq() +int strlen(), lexnum(), ctod(), strdic() + +begin + call smark (sp) + call salloc (temp, SZ_LINE, TY_CHAR) + + if (datatype < 0) + + # The only check on string types is that they not exceed their + # maximum length + + match = strlen (field) <= -(datatype) + + else { + + # Get the data type of the string + # Reduce this to character, integer or real + # Get the value of the string if it is not character + + if (streq (field, "INDEF")) { + fieldtype = datatype + fieldval = 0.0 + + } else { + ic = 1 + lextype = lexnum (field, ic, nc) + + for (ic = ic + nc; IS_WHITE(field[ic]); ic = ic + 1) + ; + if (field[ic] != EOS) + lextype = LEX_NONNUM + + if (lextype == LEX_HEX || lextype == LEX_NONNUM) { + fieldtype = TY_CHAR + fieldval = 0.0 + } else { + if (lextype == LEX_REAL) + fieldtype = TY_REAL + else + fieldtype = TY_INT + + ic = 1 + nc = ctod (field, ic, fieldval) + fieldval = abs (fieldval) + } + } + + # See if the string matches the expected datatype + + switch (datatype) { + case TY_BOOL: + match = strdic (field, Memc[temp], SZ_LINE, yorn) > 0 + case TY_CHAR: + match = strlen (field) <= 1 + case TY_SHORT: + match = fieldtype == TY_INT && fieldval <= MAX_SHORT + case TY_INT: + match = fieldtype == TY_INT && fieldval <= MAX_INT + case TY_LONG: + match = fieldtype == TY_INT && fieldval <= MAX_LONG + case TY_REAL: + match = fieldtype != TY_CHAR && fieldval <= MAX_REAL + case TY_DOUBLE: + match = fieldtype != TY_CHAR && fieldval <= MAX_DOUBLE + default: + match = true + } + } + + call sfree (sp) + return (match) +end + +# DRAW_FIELD -- Draw a single field on the screen + +procedure draw_field (scr) + +pointer scr # i: screen descriptor +#-- +char blank +pointer sp, value, field, tab +int win, tabrow, tabcol, row, col, orow, ocol + +data blank / ' ' / + +int winstat() + +begin + # Allocate dynamic memory to hold string + + call smark (sp) + call salloc (value, SZ_FIELD, TY_CHAR) + call salloc (field, SZ_FIELD, TY_CHAR) + + # Get current value + + win = TED_WINDOW(scr) + tab = TED_TABLE(scr) + + tabrow = TED_CURROW(scr) + tabcol = TED_CURCOL(scr) + + call tbegtt (TED_TABPTR(tab), TED_COLPTR(tab,tabcol), + tabrow, Memc[value], SZ_FIELD) + + call align_field (LEFT, blank, Memc[value], + Memc[field], TED_COLLEN(tab,tabcol)) + + # Redraw field and reposition cursor + + orow = winstat (win, W_CURROW) + ocol = winstat (win, W_CURCOL) + + call pos_field (scr, 1, row, col) + call wmove (win, row, col) + + call waddstr (win, Memc[field]) + call wmove (win, orow, ocol) + + call sfree (sp) +end + +# EDIT_FIELD -- Interactively edit a table field + +procedure edit_field (win, field, maxch) + +int win # i: Window descriptor +char field[ARB] # u: Table field +int maxch # i: Maximum line length +#-- +int row, col, ch, ic, jc, mc, nc +pointer sp, data, buffer + +string nowrite "Cannot change field: table is read only" +string fullfld "Cannot undelete word: not enough room in field" + +int strlen(), k_get(), winstat() + +begin + call wgetstruct (win, data) + + nc = strlen (field) + ic = min (TED_FINDEX(data) - 1, nc) + + row = winstat (win, W_CURROW) + col = winstat (win, W_CURCOL) - ic + + call smark (sp) + call salloc (buffer, SZ_FIELD, TY_CHAR) + Memc[buffer] = EOS + + TED_COMMAND(data) = NO + + repeat { + + # Read character from keyboard + + call ps_synch + ch = k_get () + + if (ch < K_BASE) { + # Move to next field down + + if (ch == '\r') { + TED_DIRECT(data) = LEFT + TED_NXTROW(data) = TED_NXTROW(data) + 1 + break + + # Move to next field across + + } else if (ch == '\t') { + if (TED_NXTCOL(data) < TED_LSTCOL(data)) { + TED_DIRECT(data) = LEFT + TED_NXTCOL(data) = TED_NXTCOL(data) + 1 + break + } + + # Insert character at current position + + } else if (TED_RDOFLD(data) == NO) { + + # Check to see if field is full, if so, truncate + + if (nc >= maxch) { + nc = maxch - 1 + field[nc+1] = EOS + if (ic > nc) { + ic = nc + call wmove (win, row, col+ic) + } + } + + ic = ic + 1 + nc = nc + 1 + TED_MRKFLD(data) = YES + + if (ic == nc) { + field[ic] = ch + field[ic+1] = EOS + call waddstr (win, field[ic]) + + } else { + do jc = nc, ic, -1 + field[jc+1] = field[jc] + + field[ic] = ch + call waddstr (win, field[ic]) + call wmove (win, row, col+ic) + } + + # Print warning message, read_only field + + } else { + call warn1_prompt (TED_FSCREEN(data), nowrite) + } + + } else { + switch (ch) { + case K_UP: # Move up one field + if (TED_NXTROW(data) > 1) { + TED_DIRECT(data) = CENTER + TED_NXTROW(data) = TED_NXTROW(data) - 1 + break + } + + case K_DOWN: # Move down one field + if (TED_NXTROW(data) < TED_LSTROW(data)) { + TED_DIRECT(data) = CENTER + TED_NXTROW(data) = TED_NXTROW(data) + 1 + break + } + case K_RIGHT: # Move right one column + if (ic < nc) { + ic = ic + 1 + call wmove (win, row, col+ic) + + } else if (TED_NXTCOL(data) < TED_LSTCOL(data)) { + TED_DIRECT(data) = LEFT + TED_NXTCOL(data) = TED_NXTCOL(data) + 1 + break + } + + case K_LEFT: # Move left one column + if (ic > 0) { + ic = ic - 1 + call wmove (win, row, col+ic) + + } else if (TED_NXTCOL(data) > 1) { + TED_DIRECT(data) = RIGHT + TED_NXTCOL(data) = TED_NXTCOL(data) - 1 + break + } + + case K_NEXTW: # Move forwards one field + if (TED_NXTCOL(data) < TED_LSTCOL(data)) { + TED_DIRECT(data) = LEFT + TED_NXTCOL(data) = TED_NXTCOL(data) + 1 + break + } + + case K_PREVW: # Move backwards one field + if (TED_NXTCOL(data) > 1) { + TED_DIRECT(data) = LEFT + TED_NXTCOL(data) = TED_NXTCOL(data) - 1 + break + } + + case K_NEXTP: # Move forwards one screen + if (TED_NXTROW(data) < TED_LSTROW(data)) { + TED_DIRECT(data) = LEFT + TED_NXTROW(data) = min (TED_LSTROW(data), + TED_NXTROW(data) + TED_PGSIZE(data)) + break + } + + case K_PREVP: # Move backwards one page + if (TED_NXTROW(data) > 1) { + TED_DIRECT(data) = LEFT + TED_NXTROW(data) = max (1, + TED_NXTROW(data) - TED_PGSIZE(data)) + break + } + + case K_HOME: # Move to first row + if (TED_NXTROW(data) > 1) { + TED_DIRECT(data) = LEFT + TED_NXTROW(data) = 1 + break + } + + case K_END: # Move to last row and column + if (TED_NXTROW(data) < TED_LSTROW(data)) { + TED_DIRECT(data) = LEFT + TED_NXTROW(data) = TED_LSTROW(data) + break + } + + case K_BOL: # Move to first column in table + if (TED_NXTCOL(data) == 1) { + ic = 0 + call wmove (win, row, col) + + } else { + TED_DIRECT(data) = LEFT + TED_NXTCOL(data) = 1 + break + } + + case K_EOL: # Move to last column in table + if (TED_NXTCOL(data) == TED_LSTCOL(data)) { + ic = nc + call wmove (win, row, col+ic) + + } else { + TED_DIRECT(data) = RIGHT + TED_NXTCOL(data) = TED_LSTCOL(data) + break + } + + case K_DEL: # Delete character underneath cursor + if (TED_RDOFLD(data) == NO) { + if (ic < nc) { + TED_MRKFLD(data) = YES + mc = strlen (Memc[buffer]) + + Memc[buffer+mc] = field[ic+1] + Memc[buffer+mc+1] = EOS + + + do jc = ic+1, nc + field[jc] = field[jc+1] + field[nc] = ' ' + field[nc+1] = EOS + + call waddstr (win, field[ic+1]) + field[nc] = EOS + nc = nc - 1 + + call wmove (win, row, col+ic) + } + } else { + call warn1_prompt (TED_FSCREEN(data), nowrite) + } + + case K_BS: # Delete character to left of cursor + if (TED_RDOFLD(data) == NO) { + if (ic > 0) { + TED_MRKFLD(data) = YES + mc = strlen (Memc[buffer]) + + do jc = mc, 0, -1 + Memc[buffer+jc+1] = Memc[buffer+jc] + Memc[buffer] = field[ic] + + ic = ic - 1 + call wmove (win, row, col+ic) + + do jc = ic+1, nc + field[jc] = field[jc+1] + field[nc] = ' ' + field[nc+1] = EOS + + call waddstr (win, field[ic+1]) + field[nc] = EOS + nc = nc - 1 + + call wmove (win, row, col+ic) + } + } else { + call warn1_prompt (TED_FSCREEN(data), nowrite) + } + + case K_DWORD: # Delete entire field + if (TED_RDOFLD(data) == NO) { + if (nc > 0) { + TED_MRKFLD(data) = YES + call strcpy (field[ic+1], Memc[buffer], nc-ic) + + do jc = ic+1, nc + field[jc] = ' ' + field[nc+1] = EOS + + call wmove (win, row, col+ic) + call waddstr (win, field[ic+1]) + + field[ic+1] = EOS + nc = ic + + call wmove (win, row, col+ic) + } + } else { + call warn1_prompt (TED_FSCREEN(data), nowrite) + } + + case K_DLINE: # Delete entire line (not supported) + call ring_bell + + case K_UNDCHR: # Undelete a character + mc = strlen (Memc[buffer]) + if (mc > 0) { + do jc = nc+1, ic+1, -1 + field[jc+1] = field[jc] + + field[ic+1] = Memc[buffer+mc-1] + Memc[buffer+mc-1] = EOS + + call waddstr (win, field[ic+1]) + + ic = ic + 1 + nc = nc + 1 + call wmove (win, row, col+ic) + } + + case K_UNDWRD: # Undelete a word + mc = strlen (Memc[buffer]) + if ((mc + nc) > maxch) { + call warn1_prompt (TED_FSCREEN(data), fullfld) + + } else if (mc > 0) { + call amovc (field[ic+1], field[ic+mc+1], nc-ic+1) + call amovc (Memc[buffer], field[ic+1], mc) + + Memc[buffer] = EOS + call waddstr (win, field[ic+1]) + + ic = ic + mc + nc = nc + mc + call wmove (win, row, col+ic) + } + + case K_UNDLIN: # Undelete a line (not supported) + call ring_bell + + case K_HELP: # Display help screen + call help_screen (win) + + case K_PAINT: # Force screen redraw + call clearok (STDSCR, true) + call wrefresh (STDSCR) + call focus_window (win) + + case K_EXIT: # Exit procedure + TED_COMMAND(data) = YES + break + + default: + call ring_bell + } + } + } + + # Terminate field with EOS and push back character + # that terminated input + + if (nc >= maxch) + ch = EOS + + field[nc+1] = EOS + call k_pushbk (ch) + + TED_FINDEX(data) = ic + 1 + +end + +procedure move_field (scr) + +pointer scr # i: screen descriptor +#-- +int row, col + +begin + # Calculate the screen row and column and move the cursor there + + call pos_field (scr, TED_SCRIDX(scr), row, col) + call wmove (TED_WINDOW(scr), row, col) + +end + +# POS_FIELD -- Find the cursor position in a field + +procedure pos_field (scr, index, row, col) + +pointer scr # i: screen descriptor +int index # i: index of character in current field +int row # o: window row +int col # o: window column +#-- +int icol +pointer tab + +begin + # Get the table assoicated with this screen + + tab = TED_TABLE(scr) + + # Calculate the screen row and column + + row = TED_LABHEIGHT(tab) + 1 + TED_CURROW(scr) - TED_LOROW(scr) + + col = TED_LABWIDTH(tab) + 1 + do icol = TED_LOCOL(scr), TED_CURCOL(scr) - 1 + col = col + TED_COLLEN(tab,icol) + 1 + + col = col + index +end + +# TRIM_FIELD -- Remove leading and trailing blanks from field + +procedure trim_field (scr, rdonly, coltype, collen, field) + +pointer scr # i: screen descriptor +int rdonly # i: read only table +int coltype # i: column type +int collen # i: column length +char field[ARB] # u: field to trim +#-- +int ibeg, iend, ic, jc + +string toolong "Field too long to display, editing will cause loss of data" +int strlen() + +begin + if (coltype < 0) { + # Get the start and end of the string + + ibeg = 1 + iend = strlen (field) + if (iend > collen) { + iend = collen + if (rdonly == NO) + call write_prompt (scr, NO, toolong) + } + + } else { + # Get the first and last characters in the string + # which are not blank + + ibeg = 0 + iend = 0 + for (ic = 1; field[ic] != EOS; ic = ic + 1) { + if (field[ic] != ' ') { + if (ibeg == 0) + ibeg = ic + iend = ic + } + } + } + + # Trim the field to the correct length + + if (ibeg <= 1) { + jc = iend + 1 + } else { + jc = 1 + for (ic = ibeg; ic <= iend; ic = ic + 1) { + field[jc] = field[ic] + jc = jc + 1 + } + } + + field[jc] = EOS + +end diff --git a/pkg/utilities/nttools/tedit/mkpkg b/pkg/utilities/nttools/tedit/mkpkg new file mode 100644 index 00000000..6b187882 --- /dev/null +++ b/pkg/utilities/nttools/tedit/mkpkg @@ -0,0 +1,27 @@ +# Update the tedit application code in the ttools package library. +# Author: BSIMON, 1-APR-91 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + @display + + bell.x + command.x "command.com" "command.h" "field.h" "paste.h" \ + "table.h" "screen.h" + edit.x "command.h" + field.x "field.h" "table.h" "screen.h" "display/curses.h" \ + + paste.x "paste.h" "table.h" "screen.h" + prompt.x "screen.h" "display/curses.h" + screen.x "field.h" "table.h" "screen.h" \ + "display/curses.h" + substitute.x + table.x "field.h" "table.h" "screen.h" + tedit.x + tread.x + window.x "window.com" "screen.h" "display/curses.h" + ; diff --git a/pkg/utilities/nttools/tedit/paste.h b/pkg/utilities/nttools/tedit/paste.h new file mode 100644 index 00000000..92d47fbd --- /dev/null +++ b/pkg/utilities/nttools/tedit/paste.h @@ -0,0 +1,6 @@ +# PASTE.H -- Tedit paste table descriptor + +define TED_PSTLEN 2 # paste descriptor length + +define TED_PSTPTR Memi[$1] # paste table pointer +define TED_PSTROWS Memi[$1+1] # number of rows in paste table diff --git a/pkg/utilities/nttools/tedit/paste.x b/pkg/utilities/nttools/tedit/paste.x new file mode 100644 index 00000000..f4c9735d --- /dev/null +++ b/pkg/utilities/nttools/tedit/paste.x @@ -0,0 +1,142 @@ +include +include "screen.h" +include "table.h" +include "paste.h" + +define char_ 90 # goto label +define EXTRA_SPACE 20 # extra row length & col descr space + +# CLS_PASTE -- Close the paste table and free the descriptor + +procedure cls_paste (scr) + +pointer scr # u: Screen descriptor +#-- +pointer sp, fname, paste + +string nodelete "Could not delete paste table" + +begin + paste = TED_PASTE(scr) + if (paste == NULL) + return + + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + call tbtnam (TED_PSTPTR(paste), Memc[fname], SZ_FNAME) + call tbtclo (TED_PSTPTR(paste)) + + iferr (call delete (Memc[fname])) + call warn2_prompt (scr, nodelete, Memc[fname]) + + call mfree (paste, TY_STRUCT) + TED_PASTE(scr) = NULL + call sfree (sp) + +end + +# MOVE_PASTE -- Move rows to or from the paste table + +procedure move_paste (itp, otp, irow, orow, ncopy) + +pointer itp # i: pointer to descriptor for input table +pointer otp # i: pointer to descriptor for output table +int irow # i: first row of input table to be copied +int orow # i: row number of first output row +int ncopy # i: number of rows to copy +#-- +int jrow, krow + +begin + krow = orow + do jrow = irow, irow+ncopy-1 { + call tbrcpy (itp, otp, jrow, krow) + krow = krow + 1 + } +end + +# OPN_PASTE -- Open the paste table + +pointer procedure opn_paste (scr) + +pointer scr # u: Screen descriptor +pointer paste # o: Paste descriptor +#-- +int try, junk, ncol +pointer sp, oldtab, newtab, newdir, tab, tp, pp +pointer fname + +int tbpsta(), tbparse() +pointer fnldir(), tbtopn() + +string nopaste "Cannot create paste table. Command aborted." + +begin + # Allocate dynamic memory for file names + + call smark (sp) + call salloc (oldtab, SZ_FNAME, TY_CHAR) + call salloc (newtab, SZ_FNAME, TY_CHAR) + call salloc (newdir, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Get table name (used to build paste table name) + + tab = TED_TABLE(scr) + tp = TED_TABPTR(tab) + + call tbtnam (tp, Memc[oldtab], SZ_FNAME) + junk = tbparse (Memc[oldtab], Memc[fname], Memc[newdir], SZ_FNAME, + junk) # added by PEH, 1998 Apr 15 + junk = fnldir (Memc[fname], Memc[newdir], SZ_FNAME) + + # Try to open the paste table in the same directory as the + # temporary table. If this doesn't work, try the tmp$ directory + + pp = NULL + do try = 1, 2 { + call strcat ("paste", Memc[newdir], SZ_FNAME) + call mktemp (Memc[newdir], Memc[newtab], SZ_FNAME) + + ifnoerr (pp = tbtopn (Memc[newtab], NEW_COPY, tp)) + break + + call strcpy ("tmp$", Memc[newdir], SZ_FNAME) + } + + if (pp == NULL) { + call warn1_prompt (scr, nopaste) + TED_PASTE(scr) = NULL + return (NULL) + } + + # Set the parameters of the paste table, then create it + + ncol = tbpsta (tp, TBL_MAXCOLS) + + call tbpset (pp, TBL_WHTYPE, TBL_TYPE_S_ROW) + call tbpset (pp, TBL_INCR_ROWLEN, EXTRA_SPACE) + call tbpset (pp, TBL_MAXCOLS, ncol + EXTRA_SPACE) + call tbpset (pp, TBL_MAXPAR, 0) # no header parameters + + iferr (call tbtcre (pp)) { + call warn1_prompt (scr, nopaste) + TED_PASTE(scr) = NULL + return (NULL) + } + + # Create paste table descriptor + + call malloc (paste, TED_PSTLEN, TY_STRUCT) + TED_PSTPTR(paste) = pp + TED_PSTROWS(paste) = 0 + + # Update the screen structure and return the paste descriptor + + TED_PASTE(scr) = paste + + call sfree (sp) + return (paste) + +end diff --git a/pkg/utilities/nttools/tedit/prompt.x b/pkg/utilities/nttools/tedit/prompt.x new file mode 100644 index 00000000..24d2be70 --- /dev/null +++ b/pkg/utilities/nttools/tedit/prompt.x @@ -0,0 +1,225 @@ +include "display/curses.h" +include "screen.h" + +# BOOL_PROMPT -- Get a yes or no response from the user + +bool procedure bool_prompt (msg) + +char msg[ARB] # i: message to print in the prompt area +#-- +int index +pointer sp, resp, msg2 + +string yorn "|yes|no|" + +int strdic() + +begin + # Allocate memory for temporary strings + + call smark (sp) + call salloc (resp, SZ_FNAME, TY_CHAR) + call salloc (msg2, SZ_LINE, TY_CHAR) + + # Prompt the user for a response + + call read_prompt (msg, Memc[resp], SZ_FNAME) + call strlwr (Memc[resp]) + + # See if the response is yes or no, + # if it isn't, keep asking + + index = strdic (Memc[resp], Memc[resp], SZ_FNAME, yorn) + while (index == 0) { + call strcpy ("Please answer yes or no. ", Memc[msg2], SZ_LINE) + call strcat (msg, Memc[msg2], SZ_LINE) + + call read_prompt (Memc[msg2], Memc[resp], SZ_FNAME) + call strlwr (Memc[resp]) + + index = strdic (Memc[resp], Memc[resp], SZ_FNAME, yorn) + } + + # Convert result into boolean value + + call sfree (sp) + return (index == 1) +end + +# CLEAR_PROMPT -- Clear the prompt window + +procedure clear_prompt (scr) + +pointer scr # i: Currently active screen +#-- +int win + +int prompt_window() + +begin + win = prompt_window () + call werase (win) + + if (scr != NULL) + call focus_window (TED_WINDOW(scr)) + +end + +# ERR1_PROMPT -- Write an error message in the prompt area of the screen + +procedure err1_prompt (msg) + +char msg[ARB] # i: Message to write +#-- + +begin + call eprintf ("\r\n") + call error (1, msg) +end + +# ERR2_PROMPT -- Write two error messages in the prompt area of the screen + +procedure err2_prompt (msg1, msg2) + +char msg1[ARB] # i: First message to write +char msg2[ARB] # i: Second message to write +#-- +pointer msg + +begin + call salloc (msg, SZ_LINE, TY_CHAR) + + call sprintf (Memc[msg], SZ_LINE, "%s (%s)") + call pargstr (msg1) + call pargstr (msg2) + + call eprintf ("\r\n") + call error (1, Memc[msg]) + +end + +# HELP_PROMPT -- Write help message in prompt area + +procedure help_prompt (scr, bell) + +pointer scr # i: Screen descriptor +int bell # i: Ring the bell after printing message? +#-- +pointer sp, exit, msg + +string helpfmt "Type %s quit to leave editor, %s help for help." + +begin + call smark (sp) + call salloc (exit, SZ_FNAME, TY_CHAR) + call salloc (msg, SZ_LINE, TY_CHAR) + + call k_eseq ("EXIT_UPDATE", Memc[exit], SZ_FNAME) + + call sprintf (Memc[msg], SZ_LINE, helpfmt) + call pargstr (Memc[exit]) + call pargstr (Memc[exit]) + + call write_prompt (scr, bell, Memc[msg]) + call sfree (sp) +end + +# READ_PROMPT -- Read a string from the prompt area of the screen + +procedure read_prompt (msg, str, maxch) + +char msg[ARB] # i: Prompt message +char str[ARB] # o: Output string +int maxch[ARB] # i: Maximum length of output string +#-- +char blank +int win + +data blank / ' ' / + +int prompt_window() + +begin + # Write message in prompt window + + win = prompt_window () + + call werase (win) + call wmove (win, 2, 1) + call waddstr (win, msg) + call waddch (win, blank) + + # Read string from prompt window + + call wgetstr (win, str, maxch) + call werase (win) + +end + +# WARN1_PROMPT -- Write a warning message in the prompt area of the screen + +procedure warn1_prompt (scr, msg) + +pointer scr # i: Currently active screen +char msg[ARB] # i: Message to write +#-- + +begin + call write_prompt (scr, YES, msg) +end + +# WARN2_PROMPT -- Write two warning messages in the prompt area of the screen + +procedure warn2_prompt (scr, msg1, msg2) + +pointer scr # i: Currently active screen +char msg1[ARB] # i: First message to write +char msg2[ARB] # i: Second message to write +#-- +pointer sp, msg + +begin + call smark (sp) + call salloc (msg, SZ_LINE, TY_CHAR) + + call sprintf (Memc[msg], SZ_LINE, "%s (%s)") + call pargstr (msg1) + call pargstr (msg2) + + call write_prompt (scr, YES, Memc[msg]) + + call sfree (sp) +end + +# WRITE_PROMPT -- Write a message in the prompt area of the screen + +procedure write_prompt (scr, bell, msg) + +pointer scr # i: Currently active screen +int bell # i: Ring bell after writing message? +char msg[ARB] # i: Message to write +#-- +int win + +int prompt_window() + +begin + # Write message in prompt window + + win = prompt_window () + + call werase (win) + call wmove (win, 2, 1) + call waddstr (win, msg) + + # Ring the bell to wake up the user + + if (bell == YES) + call ring_bell + + # Restore cursor to original screen position + + if (scr != NULL) + call focus_window (TED_WINDOW(scr)) + +end diff --git a/pkg/utilities/nttools/tedit/screen.h b/pkg/utilities/nttools/tedit/screen.h new file mode 100644 index 00000000..ec9c6fe4 --- /dev/null +++ b/pkg/utilities/nttools/tedit/screen.h @@ -0,0 +1,18 @@ +# SCREEN.H -- Tedit screen descriptor + +define MAXSCR 10 # maximum number of screens + +define TED_SCRLEN 10 # screen descriptor length + +define TED_WINDOW Memi[$1] # window descriptor +define TED_TABLE Memi[$1+1] # table descriptor (or NULL) +define TED_PASTE Memi[$1+2] # paste table descriptor (or NULL) +define TED_LOROW Memi[$1+3] # lowest row on screen +define TED_HIROW Memi[$1+4] # highest row on screen +define TED_LOCOL Memi[$1+5] # lowest column on screen +define TED_HICOL Memi[$1+6] # highest column on the screen +define TED_CURROW Memi[$1+7] # current row on the screen +define TED_CURCOL Memi[$1+8] # current column on the screen +define TED_SCRIDX Memi[$1+9] # current character within the field + + diff --git a/pkg/utilities/nttools/tedit/screen.x b/pkg/utilities/nttools/tedit/screen.x new file mode 100644 index 00000000..5fa3e892 --- /dev/null +++ b/pkg/utilities/nttools/tedit/screen.x @@ -0,0 +1,699 @@ +include +include "display/curses.h" +include "screen.h" +include "table.h" +include "field.h" + +define HELP_FILE "ttools$tedit/tedit.key" + +# SCREEN -- Procedures which manipulate screens + +# ADD_SCREEN -- Add a new screen + +procedure add_screen (scr, table, columns, rdonly, inplace) + +pointer scr # u: Screen descriptor +char table[ARB] # i: SDAS table name +char columns[ARB] # i: list of columns to edit +bool rdonly # i: edit table read only +bool inplace # i: edit table in place +#-- +extern edit_field +int iscr, jscr +pointer oldscr, tab, win, field + +bool streq() +int get_window() +pointer map_table() + +begin + # See if the table is already bound to a screen + + jscr = 0 + for (iscr = 1; get_window (iscr, oldscr) != EOF; iscr = iscr + 1) { + tab = TED_TABLE(oldscr) + if (tab != NULL) { + if (streq (TED_TABNAME(tab), table)) { + jscr = iscr + break + } + } + } + + # Get table structure from old screen, or create new structure + + if (jscr != 0) { + TED_TABLE(scr) = TED_TABLE(oldscr) + + TED_LOROW(scr) = TED_LOROW(oldscr) + TED_HIROW(scr) = TED_HIROW(oldscr) + + TED_LOCOL(scr) = TED_LOCOL(oldscr) + TED_HICOL(scr) = TED_HICOL(oldscr) + + TED_CURROW(scr) = TED_CURROW(oldscr) + TED_CURCOL(scr) = TED_CURCOL(oldscr) + + } else { + TED_TABLE(scr) = map_table (scr, table, columns, rdonly, inplace) + + TED_LOROW(scr) = 1 + TED_HIROW(scr) = 1 + + TED_LOCOL(scr) = 1 + TED_HICOL(scr) = 1 + + TED_CURROW(scr) = 1 + TED_CURCOL(scr) = 1 + } + + TED_SCRIDX(scr) = 1 + TED_PASTE(scr) = NULL + + # Draw the new screen + + call move_screen (scr, LEFT, YES) + + # Create field structure and bind to window + + call malloc (field, TED_FLDLEN, TY_STRUCT) + + win = TED_WINDOW(scr) + call wbindstruct (win, edit_field, field) + +end + +# DEL_SCREEN -- Delete screen + +procedure del_screen (scr, force) + +pointer scr # i: Screen descriptor +int force # i: Force table to be written +#-- +int iscr, jscr +pointer sp, msg, tab1, tab2, scr2, tptr + +bool bool_prompt() +int get_window() + +begin + # Allocate dynamic memory for message + + call smark (sp) + call salloc (msg, SZ_LINE, TY_CHAR) + + # Close the paste table + + call cls_paste (scr) + + # Take no further action if no table is associated with this screen + + if (TED_TABLE(scr) == NULL) + return + + # See if this screen's table is associated with any other screen + + jscr = 0 + tab1 = TED_TABLE(scr) + tptr = TED_TABPTR(tab1) + TED_TABLE(scr) = NULL + + jscr = 0 + for (iscr = 1; get_window (iscr, scr2) != EOF; iscr = iscr + 1) { + tab2 = TED_TABLE(scr2) + if (tab2 != NULL && scr != scr2) { + if (tptr == TED_TABPTR(tab2)) { + jscr = iscr + break + } + } + } + + # If not, close the table + + if (jscr == 0) { + if (force == YES) { + call wrt_table (scr, tab1) + + } else if (TED_DIRTY(tab1) == YES){ + call sprintf (Memc[msg], SZ_LINE, "Write %s?") + call pargstr (TED_TABNAME(tab1)) + + if (bool_prompt (Memc[msg])) + call wrt_table (scr, tab1) + } + + call unmap_table (scr, tab1, force) + } + + call sfree (sp) +end + +# DRAW_SCREEN -- Draw the screen on the terminal + +procedure draw_screen (scr) + +pointer scr # i: Screen descriptor +#-- +char blank, uscore +int height, width, ic, icol, irow, junk +pointer sp, win, tab, tptr, line, temp + +data blank / ' ' / +data uscore / '_' / + +string notable "No table associated with this screen" + +int gstrcpy(), itoc() + +begin + win = TED_WINDOW(scr) + call wdimen (win, height, width) + + if (TED_TABLE(scr) == NULL) + call err1_prompt (notable) + + tab = TED_TABLE(scr) + tptr = TED_TABPTR(tab) + + call smark (sp) + call salloc (line, width+1,TY_CHAR) + call salloc (temp, SZ_LINE, TY_CHAR) + + # Erase screen window and move cursor to start of window + + call werase (win) + call wmove (win, 1, 1) + + # Write top line of screen label + + ic = gstrcpy ("Column", Memc[line], TED_LABWIDTH(tab)) + do icol = TED_LOCOL(scr), TED_HICOL(scr) { + Memc[line+ic] = ' ' + ic = ic + 1 + + junk = itoc (icol, Memc[temp], SZ_LINE) + call align_field (CENTER, blank, Memc[temp], + Memc[line+ic], TED_COLLEN(tab,icol)) + ic = ic + TED_COLLEN(tab,icol) + } + + Memc[line+ic] = '\n' + Memc[line+ic+1] = EOS + call waddstr (win, Memc[line]) + + # Write second line of screen label + + ic = gstrcpy ("Label ", Memc[line], TED_LABWIDTH(tab)) + do icol = TED_LOCOL(scr), TED_HICOL(scr) { + Memc[line+ic] = ' ' + ic = ic + 1 + + call tbcigt (TED_COLPTR(tab,icol), TBL_COL_NAME, + Memc[temp], SZ_LINE) + + call align_field (CENTER, uscore, Memc[temp], + Memc[line+ic], TED_COLLEN(tab,icol)) + ic = ic + TED_COLLEN(tab,icol) + } + + Memc[line+ic] = '\n' + Memc[line+ic+1] = EOS + call waddstr (win, Memc[line]) + + # Write the table elements a row at a time + + do irow = TED_LOROW(scr), TED_HIROW(scr) { + junk = itoc (irow, Memc[temp], SZ_LINE) + call align_field (RIGHT, blank, Memc[temp], + Memc[line], TED_LABWIDTH(tab)) + + ic = TED_LABWIDTH(tab) + do icol = TED_LOCOL(scr), TED_HICOL(scr) { + Memc[line+ic] = ' ' + ic = ic + 1 + + call tbegtt (tptr, TED_COLPTR(tab,icol), irow, + Memc[temp], SZ_LINE) + + call align_field (LEFT, blank, Memc[temp], Memc[line+ic], + TED_COLLEN(tab,icol)) + ic = ic + TED_COLLEN(tab,icol) + } + + Memc[line+ic] = '\n' + Memc[line+ic+1] = EOS + call waddstr (win, Memc[line]) + + } + + # Clear the prompt window + + call clear_prompt (NULL) + + # Move cursor to current field and refresh window + + call move_field (scr) + call wrefresh (win) + call sfree (sp) +end + +# EDIT_SCREEN -- Interactively edit the table bound to this screen + +procedure edit_screen (scr) + +pointer scr # i: Screen descriptor +#-- +int win, row, col, ch +pointer sp, field, tab, data + +string notable "No table associated with this screen" +string badtype "Illegal data type for this field" +string notadded "Cannot add row to read only table" + +bool check_field() +int tbpsta(), strlen(), k_get() + +begin + # Allocate dynamic memory for table field + + call smark (sp) + call salloc (field, SZ_FIELD, TY_CHAR) + Memc[field] = EOS + + # Get window and table associated with screen + + if (TED_TABLE(scr) == NULL) + call err1_prompt (notable) + + win = TED_WINDOW(scr) + tab = TED_TABLE(scr) + + # Initialize the field data structure + + call wgetstruct (win, data) + TED_FSCREEN(data) = scr + TED_RDOFLD(data) = TED_READONLY(tab) + TED_PGSIZE(data) = TED_HIROW(scr) - TED_LOROW(scr) + 1 + TED_LSTROW(data) = tbpsta (TED_TABPTR(tab), TBL_NROWS) + TED_LSTCOL(data) = TED_NCOLS(tab) + TED_NXTROW(data) = TED_CURROW(scr) + TED_NXTCOL(data) = TED_CURCOL(scr) + TED_DIRECT(data) = LEFT + TED_FINDEX(data) = 1 + TED_MRKFLD(data) = NO + TED_COMMAND(data) = NO + + # Edit fields until user presses the command key + + while (TED_COMMAND(data) == NO) { + + # Read the new field from the table + + row = TED_NXTROW(data) + col = TED_NXTCOL(data) + + call tbegtt (TED_TABPTR(tab), TED_COLPTR(tab,col), row, + Memc[field], SZ_FIELD) + call trim_field (scr, TED_READONLY(tab), TED_COLTYPE(tab,col), + TED_COLLEN(tab,col), Memc[field]) + + # Set the current row, column, and character + + TED_CURROW(scr) = row + TED_CURCOL(scr) = col + if (TED_DIRECT(data) == LEFT) + TED_SCRIDX(scr) = 1 + else if (TED_DIRECT(data) == RIGHT) + TED_SCRIDX(scr) = strlen(Memc[field]) + 1 + else + TED_SCRIDX(scr) = min (TED_FINDEX(data), + strlen(Memc[field]) + 1) + + call move_screen (scr, TED_DIRECT(data), NO) + + # Get the new field value + + TED_MRKFLD(data) = NO + TED_FINDEX(data) = TED_SCRIDX(scr) + call weditstr (win, Memc[field], TED_COLLEN(tab,col)) + + ch = k_get () + + # If the field has changed, check it and write it to the table + + if (TED_MRKFLD(data) == YES) { + + TED_DIRTY(tab) = YES + call tbeptt (TED_TABPTR(tab), TED_COLPTR(tab,col), + row, Memc[field]) + + # Redraw the field if it does not match the data type + + if (! check_field (TED_COLTYPE(tab,col), Memc[field])) + call draw_field (scr) + + } + + # If the cursor has moved beyond the end of the table, + # add new rows + + if (TED_NXTROW(data) > TED_LSTROW(data)) { + # Check for read only table + if (TED_READONLY(tab) == NO) { + call add_field (scr, TED_NXTROW(data), TED_NXTCOL(data)) + TED_LSTROW(data) = TED_NXTROW(data) + + } else { + call warn1_prompt (scr, notadded) + + TED_NXTROW(data) = row + TED_NXTCOL(data) = col + TED_DIRECT(data) = LEFT + } + } + } + + call sfree (sp) + +end + +# END_SCREEN -- Free all screens and their associated windows + +procedure end_screen () + +#-- + +begin + call endwin +end + +# HELP_SCREEN -- Display the help screen + +procedure help_screen (win) + +int win # i: window that currently contains the cursor +#-- +bool flag +int fd, ic, helpwin, nrows, ncols, row, ihelp, key +pointer sp, ch, eseq, label, name, msg, text + +int open(), getline(), newwin(), k_get() + +string title1 "The following commands are available after typing %s\n\n" +string title2 "The following editing commands are available\n\n" +string footer1 "\nPress any key to continue displaying commands\n" +string footer2 "\nPress any key to resume editing\n" +string hformat "%4w%-12.12s = %-12.12s" + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (eseq, SZ_FNAME, TY_CHAR) + call salloc (label, SZ_LINE/2, TY_CHAR) + call salloc (name, SZ_LINE/2, TY_CHAR) + call salloc (msg, SZ_LINE, TY_CHAR) + + # Create help window + + helpwin = newwin (GIANT, GIANT, 1, 1) + call wdimen (helpwin, nrows, ncols) + + # Display list of commands + + ifnoerr { + fd = open (HELP_FILE, READ_ONLY, TEXT_FILE) + + } then { + call k_eseq ("EXIT_UPDATE", Memc[eseq], SZ_FNAME) + call sprintf (Memc[msg], SZ_LINE, title1) + call pargstr (Memc[eseq]) + + call waddstr (helpwin, Memc[msg]) + + # Read a line at a time from the file, pausing + # to page after a window full of information + # has been displayed + + row = 3 + while (getline (fd, Memc[msg]) != EOF) { + row = row + 1 + if (row > nrows - 2) { + call waddstr (helpwin, footer1) + + row = 1 + call refresh + key = k_get () + call werase (helpwin) + } + call waddstr (helpwin, Memc[msg]) + } + call close (fd) + + call waddstr (helpwin, footer1) + call refresh + key = k_get () + } + + # Construct the list of editing commands + + call k_help (text) + + call werase (helpwin) + call waddstr (helpwin, title2) + + row = 3 + ihelp = 0 + flag = true + + # Retrieve the command name and control sequence from the help + # structure. Write the information to the help window. + + for (ch = text; Memc[ch] != EOS; ch = ch + 1) { + if (flag) { + if (Memc[ch] != '=') { + Memc[label+ic] = Memc[ch] + ic = ic + 1 + } else { + Memc[label+ic] = EOS + flag = false + ic = 0 + } + } else { + if (Memc[ch] != '\n') { + Memc[name+ic] = Memc[ch] + ic = ic + 1 + } else { + Memc[name+ic] = EOS + ihelp = ihelp + 1 + flag = true + ic = 0 + + call sprintf (Memc[msg], SZ_LINE, hformat) + call pargstr (Memc[label]) + call pargstr (Memc[name]) + + call waddstr (helpwin, Memc[msg]) + + if (mod (ihelp, 2) == 0) { + call waddstr (helpwin, "\n") + + row = row + 1 + if (row >= nrows - 2) { + call waddstr (helpwin, footer1) + + row = 1 + call refresh + key = k_get () + call werase (helpwin) + } + } + } + } + } + + if (mod (ihelp, 2) == 1) + call waddstr (helpwin, "\n") + call waddstr (helpwin, footer2) + + call refresh + key = k_get () + + # Delete the help window and restore cursor to current window + + call delwin (helpwin) + call focus_window (win) + + call sfree (sp) +end + +# INIT_SCREEN -- Initialize the screen handling routines + +procedure init_screen (table, columns, rdonly, inplace, scr) + +char table[ARB] # i: SDAS table name +char columns[ARB] # i: list of columns to edit +bool rdonly # i: edit table read only +bool inplace # i: edit table in place +pointer scr # o: initial screen +#-- + +begin + # Initialize the window handling routines + + call initscr + + # Create the first (and default) screen + + call init_window (scr) + call add_screen (scr, table, columns, rdonly, inplace) + +end + +# JOIN_SCREEN -- Remove this screen from the terminal display + +procedure join_screen (scr, force) + +pointer scr # u: Screen descriptor +int force # i: Force screen to be written +#-- + +int count_window() + +begin + if (count_window () < 2) + return + + call del_screen (scr, force) + call join_window (scr) + +end + +# MOVE_SCREEN -- Move the table (scroll) within the screen + +procedure move_screen (scr, align, force) + +pointer scr # i: screen descriptor +int align # i: column alignment +int force # i: force redraw +#-- +int row, col, tabrows, tabcols, nrows, ncols, newrow, newcol, icol +pointer sp, tab, errmsg + +string notable "No table associated with this screen" +string badsize "Screen size error: t= %d b= %d l= %d r= %d" + +int tbpsta() + +begin + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + if (TED_TABLE(scr) == NULL) + call err1_prompt (notable) + + # First check whether field is currently on the screen + + row = TED_CURROW(scr) + col = TED_CURCOL(scr) + + if (row >= TED_LOROW(scr) && row <= TED_HIROW(scr) && + col >= TED_LOCOL(scr) && col <= TED_HICOL(scr) && force == NO) { + call move_field (scr) + return + } + + # Get dimensions of table and window + + tab = TED_TABLE(scr) + tabrows = tbpsta (TED_TABPTR(tab), TBL_NROWS) + call wdimen (TED_WINDOW(scr), nrows, ncols) + + if (row < TED_LOROW(scr) || row > TED_HIROW(scr)) { + newrow = max (1, row - (nrows - TED_LABHEIGHT(tab))/ 2) + } else { + newrow = TED_LOROW(scr) + } + + if (col < TED_LOCOL(scr) || col > TED_HICOL(scr)) { + newcol = col + } else if (align == LEFT) { + newcol = TED_LOCOL(scr) + } else { + newcol = TED_HICOL(scr) + } + + # Update screen descriptor + + TED_LOROW(scr) = max (newrow, 1) + TED_HIROW(scr) = (nrows - TED_LABHEIGHT(tab)) + (newrow - 1) + TED_HIROW(scr) = min (TED_HIROW(scr), tabrows) + + tabcols = TED_LABWIDTH(tab) + if (align == LEFT) { + TED_LOCOL(scr) = max (newcol, 1) + TED_HICOL(scr) = TED_NCOLS(tab) + do icol = newcol, TED_NCOLS(tab) { + tabcols = tabcols + TED_COLLEN(tab,icol) + 1 + if (tabcols >= ncols) { + TED_HICOL(scr) = icol - 1 + break + } + } + + } else { + TED_LOCOL(scr) = 1 + TED_HICOL(scr) = min (newcol, TED_NCOLS(tab)) + do icol = newcol, 1, -1 { + tabcols = tabcols + TED_COLLEN(tab,icol) + 1 + if (tabcols >= ncols) { + TED_LOCOL(scr) = icol + 1 + break + } + } + } + + # Sanity check for new descriptor values + + if (TED_LOROW(scr) > TED_HIROW(scr) || + TED_LOCOL(scr) > TED_HICOL(scr) ) { + + call sprintf (Memc[errmsg], SZ_LINE, badsize) + call pargi (TED_LOROW(scr)) + call pargi (TED_HIROW(scr)) + call pargi (TED_LOCOL(scr)) + call pargi (TED_HICOL(scr)) + + call err1_prompt (Memc[errmsg]) + } + + # Redraw screen + + call draw_screen (scr) + call sfree (sp) +end + +procedure split_screen (scr1, scr2, table, columns, rdonly, inplace) + +pointer scr1 # u: current screen +pointer scr2 # o: new screen +char table[ARB] # i: SDAS table name +char columns[ARB] # i: list of columns to edit +bool rdonly # i: edit table read only +bool inplace # i: edit table in place +#-- + +begin + # Create new window + + call split_window (scr1, scr2) + if (scr2 == NULL) + return + + # Fill in the descriptor fields + + call add_screen (scr2, table, columns, rdonly, inplace) + +end + diff --git a/pkg/utilities/nttools/tedit/substitute.x b/pkg/utilities/nttools/tedit/substitute.x new file mode 100644 index 00000000..963d2786 --- /dev/null +++ b/pkg/utilities/nttools/tedit/substitute.x @@ -0,0 +1,372 @@ +.help substitute +.nf____________________________________________________________________________ + +This procedure searches for and replaces text patterns in a string. +The text patterns are passed to the procedure as arguments, so this +procedure can be used to perform a variety of text processing tasks. +The procedure has four arguments: a target pattern string (from), a +replacement pattern string (to), the string to be modified (str), and +a maximum length for this string (maxch). The syntax for the target +and replacement pattern strings largely follows that used in the +substitute command by the Unix text editors `ed' and `ex'. The pattern +consists of a sequence of ordinary characters, which match themselves, +and metacharacters, which match a set of characters. A metacharacter +can be matched as if it were an ordinary character by preceding it +with the escape character, `\'. For example, the escape character +itself is indicated in a pattern by `\\'. The metacharacters which can +be used in the target pattern are: + + beginning of string ^ end of string $ + white space # escape character \ + ignore case { end ignore case } + begin character class [ end character class ] + not, in char class ^ range, in char class - + one character ? zero or more occurences * + begin tagged string \( end tagged string \) + + +A set of characters is indicated in the target string by the character +class construct. For example, punctuation could be indicated by +`[,;.!]'. A range of characters contiguous in the underlying +character set can be abbreviated by the range construct. For example, +`[a-z]' matches any lower case character. The complement of a +character set is indicated by making `^' the first character in a +class. For example, `[^0-9]' matches any non-digit. Repetition of a +character or character class is indicated by the following it with the +`*' metacharacter. Thus, zero or more occurences of a lower case +character is indicated by `[a-z]*'. The tagged string metacharacters +have no effect on the match, they only serve to identify portions of +the matched string for the replacement pattern. The metacharacters +which are used in the replacement pattern are the following: + + entire string & tagged string \n + capitalize \u upper case \U + lower case \L end case conversion \e \E + +The ditto metacharacter, `&', indicates that the entire portion of the +string that was matched by the target pattern. The tag metacharacter +indicates that the n-th tagged string. For example, `\1' indicates +the first tagged string and `\2' the second. The remaining +metacharacters affect the case of the output string. The +capitalization metacharacter only affects the immediately following +metacharacter, but the upper and lower case metacharacters must be +turned off explicitly with `\e' or `\E'. The following are a few +examples of the results that can be obtained with this subroutine: + + from to action + ---- -- ------ + IRAF SDAS convert all mentions + of IRAF to SDAS + [a-z][A-Za-z]* \u& capitalize all words + "\([^"]*\)" '\1' convert double quoted + strings to single + quoted strings + \([^,]*\),\(?*\) \2,\1 reverse two fields + separated by commas + +.endhelp_______________________________________________________________________ + +include + +define DITTO -1 # substitute matched expression +define TAG -2 # substitute tagged part of matched expression +define CAP -3 # capitalize next char +define UCASE -4 # convert to upper case +define LCASE -5 # convert to lower case +define ENDCASE -6 # end case conversion + +define CH_ESCAPE '\\' +define CH_DITTO '&' +define CH_LTAG '(' +define CH_RTAG ')' +define CH_INDEX '%' + +#* HISTORY * +#* B.Simon 08-Dec-87 First code +#* B.Simon 05-Jan-93 Modified for substitute command + +# SUBSTITUTE -- Substitute characters in second pattern for first pattern + +bool procedure substitute (from, to, str, maxch) + +char from[ARB] # i: Target pattern +char to[ARB] # i: Replacement pattern +char str[ARB] # u: String to be modified +int maxch # i: Maximum length of string +#-- +bool match +int maxpat, ic, jc, nc +pointer sp, pat, sub, temp + +int pat_amatch() + +begin + # Allocate memory for temporary strings + + maxpat = maxch + SZ_LINE + + call smark (sp) + call salloc (pat, maxpat, TY_CHAR) + call salloc (sub, maxpat, TY_CHAR) + call salloc (temp, maxch, TY_CHAR) + + # Encode target and replacement patterns + + call code_pat (from, Memc[pat], maxpat) + call code_sub (to, Memc[sub], maxpat) + + # Perform an anchored match at each character of the string. + # If there is a match, substitute the replacement pattern for + # the target. Otherwise move the character to the output unchanged + + ic = 1 + jc = 1 + match = false + + while (str[ic] != EOS) { + nc = pat_amatch (str, ic, Memc[pat]) + if (nc > 0) { + match = true + call make_sub (Memc[pat], Memc[sub], str, ic, ic+nc-1, + Memc[temp], jc, maxch) + + } else { + nc = 1 + if (jc <= maxch) { + Memc[temp+jc-1] = str[ic] + jc = jc + 1 + } + } + + ic = ic + nc + } + + # Copy from temporary output string back to the original string + + Memc[temp+jc-1] = EOS + call strcpy (Memc[temp], str, maxch) + + # Return status indicates if there were any matches + + call sfree (sp) + return (match) + +end + +# CODE_PAT -- Encode the target pattern + +procedure code_pat (from, pat, maxch) + +char from[ARB] # i: Target string +char pat[ARB] # o: Encoded target pattern +int maxch # i: Maximum length of pattern +#-- +char ch +int ic, jc, nc +pointer sp, temp + +int patmake() + +begin + # Allocate memory for temporary string + + call smark (sp) + call salloc (temp, maxch, TY_CHAR) + + # Convert target string to a form acceptable to the IRAF pattern + # matcher by converting tagged strings to index characters. Also + # escape any index characters which might already be in the string. + + ic = 1 + jc = 1 + while (from[ic] != EOS) { + if (from[ic] == CH_ESCAPE) { + if (from[ic+1] == CH_LTAG || from[ic+1] == CH_RTAG) { + ch = CH_INDEX + ic = ic + 1 + } else { + ch = from[ic] + } + + } else if (from[ic] == CH_INDEX) { + if (jc <= maxch) { + Memc[temp+jc-1] = CH_ESCAPE + jc = jc + 1 + } + ch = from[ic] + + } else { + ch = from[ic] + } + + if (jc <= maxch) { + Memc[temp+jc-1] = ch + jc = jc + 1 + } + + ic = ic + 1 + } + + # Call the IRAF pattern encoder to encode the converted string + + Memc[temp+jc-1] = EOS + nc = patmake (Memc[temp], pat, maxch) + + call sfree (sp) +end + +# CODE_SUB -- Encode the replacement pattern + +procedure code_sub (to, sub, maxch) + +char to[ARB] # i: Replacement string +char sub[ARB] # o: Encoded replacement pattern +int maxch # i: Maximum length of encoded pattern +#-- +char ch +int ic, jc + +int cctoc() + +begin + # Convert special characters in replacement pattern to codes + # Also convert escape sequences to single characters + + ic = 1 + jc = 1 + + while (to[ic] != EOS) { + if (to[ic] == CH_DITTO) { + ch = DITTO + + } else if (to[ic] == CH_ESCAPE) { + switch (to[ic+1]) { + case 'u': + ch = CAP + ic = ic + 1 + case 'U': + ch = UCASE + ic = ic + 1 + case 'L': + ch = LCASE + ic = ic + 1 + case 'e', 'E': + ch = ENDCASE + ic = ic + 1 + default: + if (IS_DIGIT(to[ic+1])) { + if (jc <= maxch) { + sub[jc] = TAG + jc = jc + 1 + } + ch = TO_INTEG(to[ic+1]) + ic = ic + 1 + + } else if (cctoc (to, ic, ch) == 1) { + ch = to[ic] + + } else { + ic = ic - 1 + } + } + + } else { + ch = to[ic] + } + + if (jc <= maxch) { + sub[jc] = ch + jc = jc + 1 + } + + ic = ic + 1 + } + + sub[jc] = EOS + +end + +# COPY_SUB -- Move input characters to the output string + +procedure copy_sub (str1, first, last, caseflag, str2, len, maxch) + +char str1[ARB] # i: Input string +int first # i: First character to be moved +int last # i: Last character to be moved +int caseflag # u: Case conversion flag +char str2[ARB] # u: Output string +int len # u: Length of output string +int maxch # i: Maximum length of output string +#-- +char ch +int ic + +begin + do ic = first, last { + switch (caseflag) { + case ENDCASE: + ch = str1[ic] + case LCASE: + ch = str1[ic] + if (IS_UPPER (ch)) + ch = TO_LOWER (ch) + case UCASE,CAP: + ch = str1[ic] + if (IS_LOWER (ch)) + ch = TO_UPPER (ch) + default: + ch = str1[ic] + } + + if (len <= maxch) { + str2[len] = ch + len = len + 1 + } + + if (caseflag == CAP) + caseflag = ENDCASE + } +end + +# MAKE_SUB Substitute for the chars matched by the target pattern + +procedure make_sub (pat, sub, in, first, last, out, oc, maxch) + +char pat[ARB] # i: Target pattern +char sub[ARB] # i: Replacement pattern +char in[ARB] # i: Input string +int first # i: First character matched in input string +int last # i: Last character matched in input string +char out[ARB] # u: Output string +int oc # u: Last character in output string +int maxch # i: Maximum length of output string +#-- +int caseflag, ic, index, ltag, rtag + +int patindex() + +begin + caseflag = ENDCASE + for (ic = 1; sub[ic] != EOS; ic = ic + 1) { + switch (sub[ic]) { + case ENDCASE: + caseflag = ENDCASE + case LCASE: + caseflag = LCASE + case UCASE: + caseflag = UCASE + case CAP: + caseflag = CAP + case TAG: + ic = ic + 1 + index = (sub[ic] - 1) * 2 + 1 + ltag = patindex (pat, index) + rtag = patindex (pat, index+1) - 1 + call copy_sub (in, ltag, rtag, caseflag, out, oc, maxch) + case DITTO: + call copy_sub (in, first, last, caseflag, out, oc, maxch) + default: + call copy_sub (sub, ic, ic, caseflag, out, oc, maxch) + } + } +end diff --git a/pkg/utilities/nttools/tedit/table.h b/pkg/utilities/nttools/tedit/table.h new file mode 100644 index 00000000..ed6bebd5 --- /dev/null +++ b/pkg/utilities/nttools/tedit/table.h @@ -0,0 +1,22 @@ +# TABLE.H -- Tedit table descriptor + +define TED_TABLEN 13 # table descriptor length + +define TED_READONLY Memi[$1] # is table read only? +define TED_NEWTAB Memi[$1+1] # is this a new table? +define TED_INPLACE Memi[$1+2] # edit table in place? +define TED_ALLCOLS Memi[$1+3] # editing all columns? +define TED_DIRTY Memi[$1+4] # has table been modified? +define TED_TABPTR Memi[$1+5] # table pointer +define TED_NAMEPTR Memi[$1+6] # ptr to original table name +define TED_NCOLS Memi[$1+7] # number of columns +define TED_LABWIDTH Memi[$1+8] # label width +define TED_LABHEIGHT Memi[$1+9] # label height +define TED_COLARY Memi[$1+10] # array of column pointers +define TED_TYPARY Memi[$1+11] # array of column types +define TED_LENARY Memi[$1+12] # array of column lengths + +define TED_TABNAME Memc[TED_NAMEPTR($1)] # original table name +define TED_COLPTR Memi[TED_COLARY($1)+($2)-1] # column pointer +define TED_COLTYPE Memi[TED_TYPARY($1)+($2)-1] # column type +define TED_COLLEN Memi[TED_LENARY($1)+($2)-1] # column length diff --git a/pkg/utilities/nttools/tedit/table.x b/pkg/utilities/nttools/tedit/table.x new file mode 100644 index 00000000..9312a340 --- /dev/null +++ b/pkg/utilities/nttools/tedit/table.x @@ -0,0 +1,312 @@ +include +include "screen.h" +include "table.h" +include "field.h" + +# CREATE_TABLE -- Create a new table + +procedure create_table (name, tptr) + +char name[ARB] # i: Table name +pointer tptr # o: Table pointer +#-- +int code, type +pointer sp, cp, cname, cunits, ftnfmt, sppfmt, ctype, errmsg + +string newtable "Table does not exist. Create it?" +string notable "Task exit. Table does not exist." +string nocreate "Could not create table" +string nocolumn "Could not create column" +string colprompt "Column name? (Press return to exit)" + +bool bool_prompt() +int errget() +pointer tbtopn() + +begin + if (! bool_prompt (newtable)) + call err1_prompt (notable) + + call smark (sp) + call salloc (cname, SZ_COLNAME, TY_CHAR) + call salloc (cunits, SZ_COLUNITS, TY_CHAR) + call salloc (ftnfmt, SZ_COLFMT, TY_CHAR) + call salloc (sppfmt, SZ_COLFMT, TY_CHAR) + call salloc (ctype, SZ_FNAME, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + iferr { + tptr = tbtopn (name, NEW_FILE, NULL) + } then { + code = errget (Memc[errmsg], SZ_LINE) + call err2_prompt (nocreate, Memc[errmsg]) + } + + # Get parameters defining each column + + repeat { + call read_prompt (colprompt, Memc[cname], SZ_COLNAME) + if (Memc[cname] == EOS) + break + + repeat { + call read_prompt ("Column type? (r,d,i,b,ch*n)", + Memc[ctype], SZ_FNAME) + + iferr (call tbbtyp (Memc[ctype], type)) { + call ring_bell + } else { + break + } + } + + repeat { + call read_prompt ("Column format?", Memc[ftnfmt], SZ_COLFMT) + call tbbftp (Memc[ftnfmt], Memc[sppfmt]) + + if (Memc[sppfmt] == EOS && Memc[ftnfmt] != EOS) { + call ring_bell + } else { + break + } + } + + call read_prompt ("Column units?", Memc[cunits], SZ_COLUNITS) + + # Add new column to table + + iferr { + call tbcdef (tptr, cp, Memc[cname], Memc[cunits], + Memc[sppfmt], type, 1, 1) + } then { + code = errget (Memc[errmsg], SZ_LINE) + call err2_prompt (nocolumn, Memc[errmsg]) + } + } + + iferr { + call tbtcre (tptr) + } then { + code = errget (Memc[errmsg], SZ_LINE) + call err2_prompt (nocreate, Memc[errmsg]) + } + + # Add an empty row to the table + + call tbtwer (tptr, 1) + call sfree (sp) +end + +# MAP_TABLE -- Map a table into a descriptor so that it can be edited + +pointer procedure map_table (scr, table, columns, rdonly, inplace) + +pointer scr # i: Screen descriptor +char table[ARB] # i: SDAS table name +char columns[ARB] # i: list of columns to edit +bool rdonly # i: edit table read only +bool inplace # i: edit table in place +#-- +bool place, new +int dirty, numcol, numrow, numptr, iptr +int height, width, maxcol, clen +pointer sp, tabname, filename, ext, cname, tptr, tab + +string notable "Table does not exist" +string nowrite "No write access to table" +string nocols "Column names not found in table" +string emptytab "Table is empty" + +int access(), tbtacc(), tbpsta() +int tbcigi(), strlen(), btoi() + +begin + # Allocate dynamic memory for temporary names + + call smark (sp) + call salloc (tabname, SZ_FNAME, TY_CHAR) + call salloc (filename, SZ_FNAME, TY_CHAR) + call salloc (ext, SZ_COLNAME, TY_CHAR) + call salloc (cname, SZ_COLNAME, TY_CHAR) + + # Get filename from table name + + call tbfile (table, Memc[tabname], Memc[filename], Memc[ext], SZ_FNAME) + + # Check table permissions + + if (tbtacc (table) == NO) { + dirty = YES + place = true + new = true + call create_table (table, tptr) + call strcpy (table, Memc[filename], SZ_FNAME) + + } else { + dirty = NO + place = inplace + new = false + + if (access (Memc[filename], READ_WRITE, 0) == NO && ! rdonly) + call err2_prompt (nowrite, table) + + call tu_open (table, "ted", rdonly, inplace, + tptr, Memc[filename], SZ_FNAME) + } + + # Allocate descriptor + + numcol = tbpsta (tptr, TBL_NCOLS) + numrow = tbpsta (tptr, TBL_NROWS) + + call malloc (tab, TED_TABLEN, TY_STRUCT) + call malloc (TED_NAMEPTR(tab), SZ_FNAME, TY_CHAR) + call malloc (TED_COLARY(tab), numcol, TY_INT) + call malloc (TED_TYPARY(tab), numcol, TY_INT) + call malloc (TED_LENARY(tab), numcol, TY_INT) + + # Fill in scalar fields + + TED_READONLY(tab) = btoi (rdonly) + TED_NEWTAB(tab) = btoi (new) + TED_INPLACE(tab) = btoi (place) + TED_DIRTY(tab) = dirty + TED_TABPTR(tab) = tptr + + # Set the width and height of the label area surrounding + # the table display + + TED_LABWIDTH(tab) = log10 (real(numrow + 1000)) + 1.0 + TED_LABWIDTH(tab) = max (6, TED_LABWIDTH(tab)) + TED_LABHEIGHT(tab) = 2 + + call strcpy (Memc[filename], TED_TABNAME(tab), SZ_FNAME) + + # Get vector fields (column pointers, types, and lengths) + + call tctexp (tptr, columns, numcol, numptr, TED_COLPTR(tab,1)) + + TED_NCOLS(tab) = numptr + if (numptr == 0) { + call err2_prompt (nocols, columns) + } else if (numcol == numptr) { + TED_ALLCOLS(tab) = YES + } else { + TED_ALLCOLS(tab) = NO + } + + call wdimen (TED_WINDOW(scr), height, width) + maxcol = width - (TED_LABWIDTH(tab) + 2) + + do iptr = 1, numptr { + TED_COLTYPE(tab,iptr) = tbcigi (TED_COLPTR(tab,iptr), + TBL_COL_DATATYPE) + + clen = tbcigi (TED_COLPTR(tab,iptr), TBL_COL_FMTLEN) + call tbcigt (TED_COLPTR(tab,iptr), TBL_COL_NAME, + Memc[cname], SZ_COLNAME) + + TED_COLLEN(tab,iptr) = min (maxcol, max (clen, + strlen (Memc[cname]))) + } + + # Check to see if table is empty + # Write a single blank row unless table is read only + + if (numrow < 1 ) { + if (rdonly) { + call err2_prompt (emptytab, table) + } else { + TED_DIRTY(tab) = YES + call tbtwer (tptr, 1) + } + } + + # Return pointer to descriptor + + call sfree (sp) + return (tab) + end + +# UNMAP_TABLE -- Release table descriptor + +procedure unmap_table (scr, tab, force) + +pointer scr # i: Currently active screen +pointer tab # i: Table descriptor +int force # i: Force unmap if table is dirty +#-- +bool quit +pointer sp, table + +begin + # Allocate memory for strings + + call smark (sp) + call salloc (table, SZ_FNAME, TY_CHAR) + + # Close table if still open and delete if + # it was a new table that was not written or not in place + + if (TED_TABPTR(tab) != NULL) { + quit = TED_NEWTAB(tab) == YES || TED_INPLACE(tab) == NO + call tbtnam (TED_TABPTR(tab), Memc[table], SZ_FNAME) + + call tu_close (TED_TABPTR(tab), TED_INPLACE(tab), + quit, Memc[table]) + } + + # Free descriptor + + call mfree (TED_NAMEPTR(tab), TY_CHAR) + call mfree (TED_COLARY(tab), TY_INT) + call mfree (TED_TYPARY(tab), TY_INT) + call mfree (TED_LENARY(tab), TY_INT) + + call mfree (tab, TY_STRUCT) + call sfree (sp) +end + +# WRT_TABLE -- Close table and write back to original file + +procedure wrt_table (scr, tab) + +pointer scr # i: Currently active screen +pointer tab # i: Table descriptor +#-- +bool quit +pointer sp, table + +string noname "Could not rename new table, it has this temporary name" + +begin + # Return if table already written + + if (TED_TABPTR(tab) == NULL) + return + + # Allocate memory for strings + + call smark (sp) + call salloc (table, SZ_FNAME, TY_CHAR) + + # Get current file name, then close table + + quit = TED_INPLACE(tab) == NO && TED_DIRTY(tab) == NO + call strcpy (TED_TABNAME(tab), Memc[table], SZ_FNAME) + + iferr { + call tu_close (TED_TABPTR(tab), TED_INPLACE(tab), + quit, Memc[table]) + } then { + call warn2_prompt (scr, noname, Memc[table]) + TED_INPLACE(tab) = YES + } + + # Set table pointer to NULL and set newtab to NO, to mark it as written + + TED_TABPTR(tab) = NULL + TED_NEWTAB(tab) = NO + call sfree (sp) +end + diff --git a/pkg/utilities/nttools/tedit/tedit.key b/pkg/utilities/nttools/tedit/tedit.key new file mode 100644 index 00000000..6e2f358d --- /dev/null +++ b/pkg/utilities/nttools/tedit/tedit.key @@ -0,0 +1,23 @@ +All commands may be abbreviated to any unique abbreviation + +add column add a new column to the table +add row add new rows to the table +copy copy rows to paste buffer, deleting current buffer +copy append copy rows to paste buffer, saving current buffer +delete delete rows, add to paste buffer, deleting current buffer +delete append delete rows, add to paste buffer, saving current buffer +exit leave table editor after saving changes +find find next row which makes search expression true +find forward (same as find) +find backwards find previous row which makes search expression true +goto go to row and column in table +help display this file +insert insert lines from paste buffer into table +lower convert a string column to lower case +next repeat previous find command in current direction +next forward repeat previous find command in forward direction +next backwards repeat previous find command in backwards direction +quit leave table editor without saving changes +set set a column equal to an expression +substitute substitute one string for another +upper convert a string column to upper case diff --git a/pkg/utilities/nttools/tedit/tedit.x b/pkg/utilities/nttools/tedit/tedit.x new file mode 100644 index 00000000..c3ced90f --- /dev/null +++ b/pkg/utilities/nttools/tedit/tedit.x @@ -0,0 +1,33 @@ +# TEDIT -- Table editor + +procedure t_tedit () + +#-- +pointer table # SDAS table name +pointer columns # list of columns to edit +bool silent # don't ring bell when error occurs +bool rdonly # edit table read only +bool inplace # edit table in place + +pointer sp + +bool clgetb() + +begin + call smark (sp) + call salloc (table, SZ_FNAME, TY_CHAR) + call salloc (columns, SZ_FNAME, TY_CHAR) + + call clgstr ("table", Memc[table], SZ_FNAME) + call clgstr ("columns", Memc[columns], SZ_FNAME) + + silent = clgetb ("silent") + rdonly = clgetb ("rdonly") + inplace = clgetb ("inplace") + inplace = inplace || rdonly + + call edit (Memc[table], Memc[columns], silent, rdonly, inplace) + call sfree (sp) + +end + diff --git a/pkg/utilities/nttools/tedit/tread.x b/pkg/utilities/nttools/tedit/tread.x new file mode 100644 index 00000000..620c203a --- /dev/null +++ b/pkg/utilities/nttools/tedit/tread.x @@ -0,0 +1,31 @@ +# T_TREAD -- Read only table editor + +procedure t_tread () + +#-- +pointer table # SDAS table name +pointer columns # list of columns to edit +bool silent # don't ring bell when error occurs + +bool rdonly,inplace +pointer sp + +bool clgetb() + +begin + call smark (sp) + call salloc (table, SZ_FNAME, TY_CHAR) + call salloc (columns, SZ_FNAME, TY_CHAR) + + call clgstr ("table", Memc[table], SZ_FNAME) + call clgstr ("columns", Memc[columns], SZ_FNAME) + + silent = clgetb ("silent") + rdonly = true + inplace = true + + call edit (Memc[table], Memc[columns], silent, rdonly, inplace) + call sfree (sp) + +end + diff --git a/pkg/utilities/nttools/tedit/window.com b/pkg/utilities/nttools/tedit/window.com new file mode 100644 index 00000000..20ab1f11 --- /dev/null +++ b/pkg/utilities/nttools/tedit/window.com @@ -0,0 +1,8 @@ +# WINDOW.COM -- Tracks windows associated with table editor + +int wprompt # The prompt window +int nscreens # Number of screens currently displayed +int scrlist[MAXSCR] # List of screens, from top to bottom + +common /tedwin/ wprompt, nscreens, scrlist + diff --git a/pkg/utilities/nttools/tedit/window.x b/pkg/utilities/nttools/tedit/window.x new file mode 100644 index 00000000..829bb21b --- /dev/null +++ b/pkg/utilities/nttools/tedit/window.x @@ -0,0 +1,246 @@ +include "display/curses.h" +include "screen.h" + +define MAXSCR 10 +define MIN_HEIGHT 4 + +# COUNT_WINDOW -- Return number of windows + +int procedure count_window () + +#-- +include "window.com" + +begin + return (nscreens) +end + +# FOCUS_WINDOW -- Move the cursor to its current position in a window + +procedure focus_window (win) + +pointer win # i: window descriptor +#-- +int row, col + +int winstat() + +begin + row = winstat (win, W_CURROW) + col = winstat (win, W_CURCOL) + + call wmove (win, row, col) +end + +# GET_WINDOW -- Get a window from the list of screens + +int procedure get_window (iscr, scr) + +int iscr # i: index into list of screens +pointer scr # o: screen descriptor +#-- +include "window.com" + +begin + # Return EOF if this is the last screen on the list + + if (iscr > nscreens) { + scr = scrlist[1] + return (EOF) + } else { + scr = scrlist[iscr] + return (OK) + } +end + +# INIT_WINDOW -- Create the initial set of windows + +procedure init_window (scr) + +pointer scr # o: initial screen +#-- +include "window.com" + +int nrows, ncols + +int newwin() + +begin + # Get size of terminal screen + + call wdimen (STDSCR, nrows, ncols) + + # Create the initial screen + + call malloc (scr, TED_SCRLEN, TY_STRUCT) + TED_WINDOW(scr) = newwin (nrows-2, ncols, 1, 1) + TED_TABLE(scr) = NULL + + # Create the prompt window + + wprompt = newwin (2, ncols, nrows-1, 1) + + # Initialze the global variables + + nscreens = 1 + scrlist[1] = scr + +end + +# JOIN_WINDOW -- Join screen window with the adjacent window + +procedure join_window (scr) + +pointer scr # i: screen descriptor +#-- +include "window.com" + +int win1, win2 +int iscr, jscr, top, left, row1, col1, row2, col2 +pointer scr2 + +string notnull "join_window: table was not closed" +string notfound "join_window: could not find screen" + +int winstat(), newwin() + +begin + # Cannot join single screen or screen that is still open + + if (nscreens == 1 || TED_TABLE(scr) != NULL) + call err1_prompt (notnull) + + # Find the screen and its adjacent screen + # Pay attention to which screen is on top + + jscr = 0 + do iscr = 1, nscreens { + if (scrlist[iscr] == scr) { + jscr = iscr + if (jscr == 1) { + win1 = TED_WINDOW(scrlist[1]) + win2 = TED_WINDOW(scrlist[2]) + scr2 = scrlist[2] + } else { + win1 = TED_WINDOW(scrlist[jscr-1]) + win2 = TED_WINDOW(scrlist[jscr]) + scr2 = scrlist[jscr-1] + } + break + } + } + + if (jscr == 0) { + call err1_prompt (notfound) + + } else { + # Get dimensions of windows, delete them + + top = winstat (win1, W_TOP) + left = winstat (win1, W_LEFT) + + call wdimen (win1, row1, col1) + call delwin (win1) + + call wdimen (win2, row2, col2) + call delwin (win2) + + # Create new window, assign to adjacent screen + + TED_WINDOW(scr2) = newwin (row1+row2, col2, top, left) + + # Delete screen and remove from list of screens + + call mfree (scr, TY_STRUCT) + nscreens = nscreens - 1 + + do iscr= jscr, nscreens + scrlist[iscr] = scrlist[iscr+1] + } +end + +# PROMPT_WINDOW -- Return the prompt window + +int procedure prompt_window () + +#-- +include "window.com" + +begin + return (wprompt) +end + +# SPLIT_WINDOW -- Split window into two windows + +procedure split_window (scr1, scr2) + +pointer scr1 # u: current screen +pointer scr2 # o: new screen (or NULL) +#-- +include "window.com" + +int win1 +int iscr, jscr, top, left, row1, col1, row2, col2 + +string noroom "Screen is too small to split" +string notfound "split_window: could not find screen" + +int winstat(), newwin() + +begin + # Find screen in list of screens + + jscr = 0 + do iscr = 1, nscreens { + if (scr1 == scrlist[iscr]) { + jscr = iscr + break + } + } + + if (jscr == 0) { + call err1_prompt (notfound) + + } else { + # Get dimensions of current window + + win1 = TED_WINDOW(scr1) + + top = winstat (win1, W_TOP) + left = winstat (win1, W_LEFT) + + call wdimen (win1, row1, col1) + + row2 = row1 / 2 + col2 = col1 + row1 = row1 - row2 + + # Don't split window if it is too small + + if (row2 <= MIN_HEIGHT) { + call warn1_prompt (scr1, noroom) + scr2 = NULL + + } else { + # Delete current window and create new half-size window + + call delwin (win1) + TED_WINDOW(scr1) = newwin (row1, col1, top, left) + + # Create new screen and its window + + call malloc (scr2, TED_SCRLEN, TY_STRUCT) + TED_WINDOW(scr2) = newwin (row2, col2, top+row1, left) + TED_TABLE(scr2) = NULL + + # Add to list of screens + + do iscr = jscr+1, nscreens + scrlist[iscr+1] = scrlist[iscr] + + scrlist[jscr+1] = scr2 + nscreens = nscreens + 1 + } + } + +end diff --git a/pkg/utilities/nttools/texpand.par b/pkg/utilities/nttools/texpand.par new file mode 100644 index 00000000..17d6a35d --- /dev/null +++ b/pkg/utilities/nttools/texpand.par @@ -0,0 +1,6 @@ +input,s,a,,,,"Input SDAS table name" +output,s,a,,,,"Output SDAS table name" +rbase,s,a,,,,"File containing expansion rules" +debug,s,h,"",,,"File for debug output" +verbose,b,h,no,,,"Print table names?" +mode,s,h,"a",,, diff --git a/pkg/utilities/nttools/texpand/dbgrules.x b/pkg/utilities/nttools/texpand/dbgrules.x new file mode 100644 index 00000000..eeffb8e0 --- /dev/null +++ b/pkg/utilities/nttools/texpand/dbgrules.x @@ -0,0 +1,164 @@ +include + +define INT_DEFLEN 10 +define REAL_DEFLEN 14 +define DBL_DEFLEN 24 + +# DBGRULES -- Write the non-null rows in a table to a debug file +# +# B.Simon 25-Apr-88 Original + +procedure dbg_rules (tp, title, row1, row2, dbg) + +pointer tp # i: Table descriptor +char title[ARB] # i: Title to print above table +int row1 # i: First row to print +int row2 # i: Last row to print +int dbg # i: File descriptor of debug file +#-- +bool nullflg +double dblval +int pwidth, ncol, irow, icol, jcol, collen, totlen, intval +pointer sp, col,strval, colname, colptr, typptr, lenptr +real realval + +int tbpsta(), tbcnum(), tbcigi(), envgeti(), strlen() + +begin + # First, make sure there is something to print + + if (row2 < row1 || dbg == NULL) + return + + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (strval, SZ_LINE, TY_CHAR) + call salloc (colname, SZ_COLNAME, TY_CHAR) + + # Allocate dynamic memory for column arrays + + ncol = tbpsta (tp, TBL_NCOLS) + call salloc (typptr, ncol, TY_INT) + call salloc (colptr, ncol, TY_INT) + call salloc (lenptr, ncol, TY_INT) + + # Get width of terminal screen + + pwidth = envgeti ("ttyncols") + + # Print title + + call fprintf (dbg, "%s\n") + call pargstr (title) + + # Compute width of each column in output + + jcol = 0 + totlen = 0 + do icol = 1, ncol { + + # Check to see if this column is excluded from the output + + col = tbcnum (tp, icol) + call tbrgtt (tp, col, Memc[strval], nullflg, SZ_LINE, 1, row1) + + if (row1 != row2 || ! nullflg) { + jcol = jcol + 1 + + call tbcigt (col, TBL_COL_NAME, Memc[colname], SZ_COLNAME) + Memi[colptr+jcol-1] = col + Memi[typptr+jcol-1] = tbcigi (col, TBL_COL_DATATYPE) + + # Set column width to default for its type + + switch (Memi[typptr+jcol-1]) { + case TY_SHORT, TY_INT, TY_LONG: + collen = INT_DEFLEN + case TY_REAL: + collen = REAL_DEFLEN + case TY_DOUBLE: + collen = DBL_DEFLEN + default: + collen = - Memi[typptr+jcol-1] + } + + # Adjust width to allow room for column titles + + collen = max (collen, strlen (Memc[colname])) + totlen = totlen + collen + 1 + + # Write the column titles + + if (jcol > 1 && totlen > pwidth) + call fprintf (dbg, "\n") + + if (Memi[typptr+jcol-1] > 0) { + call fprintf (dbg, " %*s") + call pargi (collen) + } else { + call fprintf (dbg, " %*s") + call pargi (-collen) + } + call strupr (Memc[colname]) + call pargstr (Memc[colname]) + + # Set sign to indicate start of new line + + if (jcol > 1 && totlen > pwidth) { + totlen = collen + 1 + Memi[lenptr+jcol-2] = - Memi[lenptr+jcol-2] + } + + Memi[lenptr+jcol-1] = collen + } + } + + # Recompute number of columns and force newline at end of title row + + ncol = jcol + if (ncol > 0) + Memi[lenptr+ncol-1] = - Memi[lenptr+ncol-1] + call fprintf (dbg, "\n") + + # Read the data from the database and write the data to STDOUT + + do irow = row1, row2 { + do jcol = 1, ncol { + + col = Memi[colptr+jcol-1] + collen = abs (Memi[lenptr+jcol-1]) + + switch(Memi[typptr+jcol-1]) { + case TY_SHORT, TY_INT, TY_LONG: + call tbegti (tp, col, irow, intval) + call fprintf (dbg, " %*d") + call pargi (collen) + call pargi (intval) + case TY_REAL: + call tbegtr (tp, col, irow, realval) + call fprintf (dbg, " %*.7g") + call pargi (collen) + call pargr (realval) + case TY_DOUBLE: + call tbegtd (tp, col, irow, dblval) + call fprintf (dbg, " %*.16g") + call pargi (collen) + call pargd (dblval) + default: + call tbegtt (tp, col, irow, Memc[strval], SZ_LINE) + call fprintf (dbg, " %*s") + call pargi (-collen) + call pargstr (Memc[strval]) + } + + if (Memi[lenptr+jcol-1] < 0) + call fprintf (dbg, "\n") + + } + } + + call fprintf (dbg, "\n\n") + call sfree (sp) + +end diff --git a/pkg/utilities/nttools/texpand/lexer.x b/pkg/utilities/nttools/texpand/lexer.x new file mode 100644 index 00000000..cb4d5d7c --- /dev/null +++ b/pkg/utilities/nttools/texpand/lexer.x @@ -0,0 +1,114 @@ +include "lexoper.h" + +define start_ 90 + +# LEXER -- Lexically analyze a rule base +# +# B.Simon 25-Apr-88 Original + +procedure lexer (rb, oper, value, maxch) + +pointer rb # i: Pointer to descriptor of rule base +int oper # o: Operator type found +char value[ARB] # o: Text of operator +int maxch # i: Maximum length of string +#-- +char dic_text[2] +int junk, old_index, dic_index, dic_oper[5] +pointer sp, ch, blanks + +data dic_oper /SEPOPR, IMPOPR, OROPR, ANDOPR, EQOPR/ +string dict "/;/=>/||/&&/=/" + +bool streq() +int getline(), ctowrd(), span(), nospan(), strdic() + +begin + # Allocate an array to hold whitespace + + call smark (sp) + call salloc (blanks, SZ_LINE, TY_CHAR) + + # Skip over leading whitespace + +start_ junk = span (" \t", RB_LINE(rb), RB_INDEX(rb), Memc[blanks], SZ_LINE) + + # Branch on first non-white character + + ch = RB_CHARPTR(rb) + + # End of line or beginning of comment + + if (Memc[ch] == '\n' || Memc[ch] == '#' || Memc[ch] == EOS) { + if (getline (RB_FILE(rb), RB_LINE(rb)) == EOF) { + oper = ENDOPR + value[1] = EOS + } else { + RB_NLINE(rb) = RB_NLINE(rb) + 1 + RB_INDEX(rb) = 1 + goto start_ + } + + # Quoted identifier + + } else if (Memc[ch] == '\'' || Memc[ch] == '"') { + junk = ctowrd (RB_LINE(rb), RB_INDEX(rb), value, maxch) + oper = IDOPR + + # Unquoted identifier + + } else if (nospan ("=&|; \t\n", RB_LINE(rb), RB_INDEX(rb), + value, maxch) > 0 ) { + oper = IDOPR + + # Other operator + + } else { + old_index = RB_INDEX(rb) + junk = span ("=>&|;", RB_LINE(rb), RB_INDEX(rb), value, 2) + dic_index = strdic (value, dic_text, 2, dict) + if (dic_index > 0 && streq (value, dic_text)) { + oper = dic_oper[dic_index] + } else { + RB_INDEX(rb) = old_index + junk = ctowrd (RB_LINE(rb), RB_INDEX(rb), value, maxch) + oper = IDOPR + } + } + + call sfree (sp) +end + +# LEXINIT -- Initialize the lexical analyzer + +procedure lexinit (rbase, rb) + +char rbase[ARB] # i: Name of rule base file +pointer rb # o: Pointer to rule base descriptor +#-- + +int open() +errchk calloc, open + +begin + call malloc (rb, RB_LENGTH, TY_INT) + + RB_FILE(rb) = open (rbase, READ_ONLY, TEXT_FILE) + RB_INDEX(rb) = 1 + RB_NLINE(rb) = 0 + RB_LINE(rb) = EOS +end + +#LEXCLOSE -- Close the lexical analyzer + +procedure lexclose (rb) + +pointer rb # i: Pointer to rule base descriptor +#-- + +errchk close, mfree + +begin + call close (RB_FILE(rb)) + call mfree (rb, TY_INT) +end diff --git a/pkg/utilities/nttools/texpand/lexoper.h b/pkg/utilities/nttools/texpand/lexoper.h new file mode 100644 index 00000000..a4011143 --- /dev/null +++ b/pkg/utilities/nttools/texpand/lexoper.h @@ -0,0 +1,29 @@ + +# LEXOPER.H -- Operators and identifiers used by the lexical analyzer + +# The value of the operator type is also its priority + +define ENDOPR 1 +define SEPOPR 2 +define IMPOPR 3 +define OROPR 4 +define ANDOPR 5 +define EQOPR 6 +define IDOPR 7 + +# Pseudo-identifiers placed on the id stack + +define NAME 1 # Any identifier +define NO_IDENT 0 # No identifier on stack +define PHRASE -1 # idents joined by equals or ands +define CLAUSE -2 # idents joined by equals, ands, or ors + +# Rule base data structure + +define RB_LENGTH (SZ_LINE / SZ_INT32 + 5) + +define RB_FILE Memi[$1] +define RB_NLINE Memi[$1+1] +define RB_INDEX Memi[$1+2] +define RB_LINE Memc[P2C($1+3)] +define RB_CHARPTR (P2C($1+3) + RB_INDEX($1) - 1) diff --git a/pkg/utilities/nttools/texpand/mkpkg b/pkg/utilities/nttools/texpand/mkpkg new file mode 100644 index 00000000..241203bf --- /dev/null +++ b/pkg/utilities/nttools/texpand/mkpkg @@ -0,0 +1,21 @@ +# Update the texpand application code in the ttools package library +# Author: B.Simon, 20-APR-1989 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + dbgrules.x + lexer.x "lexoper.h" + mkrules.x + movelem.x + movtbrow.x + parser.x "lexoper.h" + pushstack.x + span.x + texpand.x + userules.x + ; + diff --git a/pkg/utilities/nttools/texpand/mkrules.x b/pkg/utilities/nttools/texpand/mkrules.x new file mode 100644 index 00000000..c1dd3aad --- /dev/null +++ b/pkg/utilities/nttools/texpand/mkrules.x @@ -0,0 +1,48 @@ +define SZ_COLVAL SZ_LINE + +# MKRULES -- Add a new rule to the target and action tables +# +# B.Simon 25-Apr-88 Original + +procedure mkrules (work, target, action) + +pointer work # i: Table containing parser results +pointer target # i: Table containing patterns to be matched +pointer action # i: Table containing possible expansions +#-- +int nwork, naction, ntarget, iwork, iaction + +int numstack() + +errchk movtbrow, putstacki + +begin + # Check for null rules + + nwork = numstack (work) + if (nwork <= 0) + return + + # Move the first row from the work table to the target table + + call pushstack (target) + naction = numstack (action) + ntarget = numstack (target) + + call movtbrow (work, 1, target, ntarget) + call putstacki (target, "_FIRST", naction+1) + call putstacki (target, "_LAST", naction+nwork-1) + call putstacki (target, "_USED", NO) + + # Move the remaining rows to the action table + + iaction = naction + do iwork = 2, nwork { + call pushstack (action) + iaction = iaction + 1 + call movtbrow (work, iwork, action, iaction) + } + + call tbrdel (work, 1, nwork) + +end diff --git a/pkg/utilities/nttools/texpand/movelem.x b/pkg/utilities/nttools/texpand/movelem.x new file mode 100644 index 00000000..e9d1f8b4 --- /dev/null +++ b/pkg/utilities/nttools/texpand/movelem.x @@ -0,0 +1,113 @@ +include + +# MOV_ELEM -- Move an element in one row from one table to another +# +# B.Simon 15-Jan-99 Original +# B.Simon 27-Jan-99 Renamed + +procedure mov_elem (rtp, rcp, rrow, wtp, wcp, wrow) + +pointer rtp # i: Table descriptor of table read from +pointer rcp # i: Column descriptor of column read from +int rrow # i: Row number of table read from +pointer wtp # i: Table descriptor of table written to +pointer wcp # i: Column descriptor of column written to +int wrow # i: Row number of table written to +#-- +int type, nelem, sz_elem, nlen +pointer sp, buf + +int tbcigi(), tbagtb(), tbagtt(), tbagti(), tbagtr(), tbagtd(), tbagts() + +begin + # First, get the type and number of elements in the column + + nelem = tbcigi (rcp, TBL_COL_LENDATA) + type = tbcigi (rcp, TBL_COL_DATATYPE) + + if (type < 0) { + sz_elem = - type + type = TY_CHAR + } else { + sz_elem = 0 + } + + # Allocate buffer to hold values passed between tables + + call smark (sp) + call salloc (buf, nelem*(sz_elem+1), type) + + # Copy the values according to their actual type + + if (nelem == 1) { + # Do not copy null scalar values + + switch (type) { + case TY_BOOL: + call tbegtb (rtp, rcp, rrow, Memb[buf]) + call tbeptb (wtp, wcp, wrow, Memb[buf]) + + case TY_CHAR: + call tbegtt (rtp, rcp, rrow, Memc[buf], sz_elem) + if (Memc[buf] != EOS) + call tbeptt (wtp, wcp, wrow, Memc[buf]) + + case TY_SHORT: + call tbegts (rtp, rcp, rrow, Mems[buf]) + if (! IS_INDEFS (Mems[buf])) + call tbepts (wtp, wcp, wrow, Mems[buf]) + + case TY_INT, TY_LONG: + call tbegti (rtp, rcp, rrow, Memi[buf]) + if (! IS_INDEFI (Memi[buf])) + call tbepti (wtp, wcp, wrow, Memi[buf]) + + case TY_REAL: + call tbegtr (rtp, rcp, rrow, Memr[buf]) + if (! IS_INDEFR (Memr[buf])) + call tbeptr (wtp, wcp, wrow, Memr[buf]) + + case TY_DOUBLE: + call tbegtd (rtp, rcp, rrow, Memd[buf]) + if (! IS_INDEFD (Memd[buf])) + call tbeptd (wtp, wcp, wrow, Memd[buf]) + } + + } else { + # Don't copy zero length arrays + + switch (type) { + case TY_BOOL: + nlen = tbagtb (rtp, rcp, rrow, Memb[buf], 1, nelem) + call tbaptb (wtp, wcp, wrow, Memb[buf], 1, nlen) + + case TY_CHAR: + nlen = tbagtt (rtp, rcp, rrow, Memc[buf], sz_elem, 1, nelem) + if (Memc[buf] != EOS) + call tbaptt (wtp, wcp, wrow, Memc[buf], sz_elem, 1, nlen) + + case TY_SHORT: + nlen = tbagts (rtp, rcp, rrow, Mems[buf], 1, nelem) + if (! IS_INDEFS (Mems[buf])) + call tbapts (wtp, wcp, wrow, Mems[buf], 1, nlen) + + case TY_INT, TY_LONG: + nlen = tbagti (rtp, rcp, rrow, Memi[buf], 1, nelem) + if (! IS_INDEFI (Memi[buf])) + call tbapti (wtp, wcp, wrow, Memi[buf], 1, nlen) + + case TY_REAL: + nlen = tbagtr (rtp, rcp, rrow, Memr[buf], 1, nelem) + if (! IS_INDEFR (Memr[buf])) + call tbaptr (wtp, wcp, wrow, Memr[buf], 1, nlen) + + case TY_DOUBLE: + nlen = tbagtd (rtp, rcp, rrow, Memd[buf], 1, nelem) + if (! IS_INDEFD (Memd[buf])) + call tbaptd (wtp, wcp, wrow, Memd[buf], 1, nlen) + } + } + + call sfree (sp) +end + diff --git a/pkg/utilities/nttools/texpand/movtbrow.x b/pkg/utilities/nttools/texpand/movtbrow.x new file mode 100644 index 00000000..9f9bb3f1 --- /dev/null +++ b/pkg/utilities/nttools/texpand/movtbrow.x @@ -0,0 +1,43 @@ +include + +# MOVTBROW -- Move columns from one table to another where not null +# +# B.Simon 25-Apr-88 Original +# B.Simon 15-Jan-99 now calls mov_elem + +procedure movtbrow (rtp, rrow, wtp, wrow) + +pointer rtp # i: Table descriptor of table read from +int rrow # i: Row number of table read from +pointer wtp # i: Table descriptor of table written to +int wrow # i: Row number of table written to +#-- +int ncol, icol +pointer sp, rcp, wcp, colname + +pointer tbpsta(), tbcnum() + +begin + call smark (sp) + call salloc (colname, SZ_COLNAME, TY_CHAR) + + ncol = tbpsta (rtp, TBL_NCOLS) + do icol = 1, ncol { + + rcp = tbcnum (rtp, icol) + call tbcigt (rcp, TBL_COL_NAME, Memc[colname], SZ_COLNAME) + call tbcfnd (wtp, Memc[colname], wcp, 1) + +# Column names beginning with an underscore are for internal +# use by the program and do not contain actual data + + if (Memc[colname] != '_' && wcp != NULL) { + + # Copy the row and column in its native type + + call mov_elem (rtp, rcp, rrow, wtp, wcp, wrow) + } + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/texpand/parser.com b/pkg/utilities/nttools/texpand/parser.com new file mode 100644 index 00000000..6dba2f6c --- /dev/null +++ b/pkg/utilities/nttools/texpand/parser.com @@ -0,0 +1,6 @@ +# PARSER.COM -- Common block containing pointer to temporary tables + +common / stkptr / ptgt, pact, pwrk + +pointer ptgt, pact, pwrk + diff --git a/pkg/utilities/nttools/texpand/parser.x b/pkg/utilities/nttools/texpand/parser.x new file mode 100644 index 00000000..2dcba75e --- /dev/null +++ b/pkg/utilities/nttools/texpand/parser.x @@ -0,0 +1,283 @@ +include +include "lexoper.h" + +define MAXSTACK 100 +define SZ_VALSTACK 3*SZ_LINE + +# PARSER -- Parse a rule base file +# +# This procedure uses a simple operator precedence parser. Every token +# retrieved from the file is either an identifier or an operator. +# Identifiers are pushed onto an identifier stack. Operators are +# pushed onto a separate operator stack. When an operator is read +# whose priority is less than that of the operator on top of the +# operator stack, the operator on the stack is popped and passed to +# a procedure which performs the appropriate action, using the +# identifiers on the identifier stack. This continues until all +# operators of higher priority have been processed, or the stack is +# empty. Syntax checking is done by checking that the identifier +# stack contains the correct number and type of identifier and that +# identifiers and operators alternate in the input. The priority of +# each operator is implicit in the integer which is used to represent +# it. For more information on operator precedence parsers, see "Writing +# Interactive Compilers and Interpreters" by P.J Brown, pp. 149-151. +# +# B.Simon 25-Apr-88 Original +# B.Simon 15-Jan-99 Skip rules with columns not in table + +procedure parser (rbase, itp, dbg, target, action) + +char rbase[ARB] # i: Rule base name +pointer itp # i: Input table descriptor +int dbg # i: Debug file descriptor +pointer target # o: Target table descriptor +pointer action # o: Action table descriptor +#-- +include "parser.com" + +bool done, expect_id +int idtop, optop, oper, tabtop, missing +int opstack[MAXSTACK] +pointer sp, rb, work, value, valstack, nxtval, colname, colval +pointer idstack[MAXSTACK] + +string find_error "Column name or type mismatch" +string stack_error "Stack overflow" +string oper_error "Operator expected" +string ident_error "Identifier expected" + +string wrkname "The parser changed the work table to the following:" + +int gstrcpy(), putstackt(), numstack() +pointer initstack() + +errchk initstack, lexinit, lexer, lexclose, syntax, typecheck, mkrules + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (value, SZ_LINE, TY_CHAR) + call salloc (valstack, SZ_VALSTACK, TY_CHAR) + + # Initialize the lexical analyzer + + call lexinit (rbase, rb) + + # Create tables used by parser + + target = initstack (itp, "_FIRST,_LAST,_USED") + action = initstack (itp, "") + work = initstack (itp, "") + + # Save copy of table pointers in common block + + ptgt = target + pact = action + pwrk = work + + # Initialize stack pointers + + idtop = 0 + optop = 0 + nxtval = valstack + + missing = NO + done = false + expect_id = true + + repeat { + + # Get next operator from rule base + + call lexer (rb, oper, Memc[value], SZ_LINE) + + # First case: operator is identifier, push on id stack + + if (oper == IDOPR) { + if (expect_id) { + idtop = idtop + 1 + if (idtop > MAXSTACK) + call syntax (rb, stack_error) + + idstack[idtop] = nxtval + nxtval = gstrcpy (Memc[value], Memc[nxtval], SZ_LINE) + + nxtval + 1 + } else { + call syntax (rb, oper_error) + } + + # Second case: operator is not identifier + + } else { + if (oper != ENDOPR && expect_id) + call syntax (rb, ident_error) + + # Process all operators whose priorities are >= + # the operator just read from the rule base + + repeat { + if (optop == 0) + break + if (oper > opstack[optop]) + break + + # Perform semantic actions associated with operators + + switch (opstack[optop]) { + case ENDOPR: + call typecheck (rb, idstack, idtop, NO_IDENT, NO_IDENT) + done = true + case SEPOPR: + call typecheck (rb, idstack, idtop, NO_IDENT, NO_IDENT) + case IMPOPR: + call typecheck (rb, idstack, idtop, PHRASE, CLAUSE) + if (missing == NO) { + call mkrules (work, target, action) + } else { + missing = NO + tabtop = numstack (work) + call tbrdel (work, 1, tabtop) + } + idtop = idtop - 2 + case OROPR: + call typecheck (rb, idstack, idtop, CLAUSE, CLAUSE) + idtop = idtop - 1 + idstack[idtop] = CLAUSE + case ANDOPR: + call typecheck (rb, idstack, idtop, PHRASE, PHRASE) + if (missing == NO) + call andstack (work) + + idtop = idtop - 1 + idstack[idtop] = PHRASE + case EQOPR: + call typecheck (rb, idstack, idtop, NAME, NAME) + colval = idstack[idtop] + colname = idstack[idtop-1] + nxtval = colname + call pushstack (work) + if (putstackt (work, Memc[colname], Memc[colval])== NO) + missing = YES + + idtop = idtop - 1 + idstack[idtop] = PHRASE + } + + optop = optop - 1 + + # Debug prints + + tabtop = numstack (work) + call dbg_rules (work, wrkname, 1, tabtop, dbg) + + } until (done) + + # Push the operator just read on the operator stack + + optop = optop + 1 + if (optop > MAXSTACK) + call syntax (rb, stack_error) + opstack[optop] = oper + } + + # Operators and identifiers should alternate in the input + + expect_id = ! expect_id + + } until (done) + + call freestack (work) + call lexclose (rb) + call sfree (sp) +end + +# TYPECHECK -- Check the number and type of identifiers on the stack + +procedure typecheck (rb, idstack, idtop, type1, type2) + +pointer rb # i: Rule base descriptor +pointer idstack[ARB] # i: Identifier stack +int idtop # i: Top of identifier stack +pointer type1 # i: Type expected for one below stack top +pointer type2 # i: Type expected for stack top +#-- +int itype +pointer id, type[2] + +string bad_type "Operator out of order" +string too_few "Missing identifier" +string too_many "Unexpected end of rule" + +begin + type[1] = type1 + type[2] = type2 + + do itype = 1, 2 { + switch (type[itype]) { + case CLAUSE: + + if (idtop < itype) + call syntax (rb, too_few) + id = idstack[idtop+itype-2] + + # a phrase is also a clause + + if (!(id == PHRASE || id == CLAUSE)) + call syntax (rb, bad_type) + + case PHRASE: + + if (idtop < itype) + call syntax (rb, too_few) + id = idstack[idtop+itype-2] + if (id != PHRASE) + call syntax (rb, bad_type) + + case NO_IDENT: + + if (idtop >= itype) + call syntax (rb, too_many) + + case NAME: + + if (idtop < itype) + call syntax (rb, too_few) + id = idstack[idtop+itype-2] + if (id <= 0) + call syntax (rb, bad_type) + + } + } + +end + +# SYNTAX -- Print a syntax error message + +procedure syntax (rb, errmsg) + +pointer rb # i: Rule base descriptor +char errmsg[ARB] # i: Error message +#-- +include "parser.com" + +begin + # Remove temporary tables + + call freestack (ptgt) + call freestack (pact) + call freestack (pwrk) + + # Print the line where the error was detected + + call eprintf ("Syntax error on line %d\n%s%*t^\n") + call pargi (RB_NLINE(rb)) + call pargstr (RB_LINE(rb)) + call pargi (RB_INDEX(rb)) + + # Close the rules file and send the error message + + call lexclose (rb) + call error (ERR, errmsg) + +end diff --git a/pkg/utilities/nttools/texpand/pushstack.x b/pkg/utilities/nttools/texpand/pushstack.x new file mode 100644 index 00000000..58d8b797 --- /dev/null +++ b/pkg/utilities/nttools/texpand/pushstack.x @@ -0,0 +1,226 @@ +include + +define SZ_COLVAL SZ_LINE + +# The following procedures treat a table as if it were a stack, that is, +# all reading and writing is done at the end of the table. The end of the +# table is indicated by TB_NROWS. +# +# B.Simon 25-Apr-88 Original +# B.Simon 27-Jan-98 Drop temporary tables + +# PUSHSTACK -- Push a null row on the top of a table stack + +procedure pushstack (tp) + +pointer tp # i: Table descriptor +#-- +int top +int tbpsta() + +begin + top = tbpsta (tp, TBL_NROWS) + 1 + call tbtwer (tp, top) +end + +# POPSTACK -- Pop the top row from a table stack + +procedure popstack (tp) + +pointer tp # i: Table descriptor +#-- +int top +int tbpsta() + +begin + top = tbpsta (tp, TBL_NROWS) + if (top > 0) + call tbrdel (tp, top, top) +end + +# NUMSTACK -- Return the number of rows in a table stack + +int procedure numstack (tp) + +pointer tp # i: Table descriptor +#-- +int tbpsta() + +begin + return (tbpsta (tp, TBL_NROWS)) +end + +# INITSTACK -- Initialize a table stack and return its descriptor + +pointer procedure initstack (tp, extra) + +pointer tp # i: Table to use as a template for the table stack +char extra[ARB] # i: Extra columns to add to the table stack +#-- +char comma +int ic, jc +pointer sp, cp, stack, colname, colunits, colfmt, tmproot, tmpfile + +int stridx() +pointer tbtopn() + +errchk tbtopn, tbtcre + +begin + # Set up arrays in dynamic memory + + call smark (sp) + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (colunits, SZ_COLUNITS, TY_CHAR) + call salloc (colfmt, SZ_COLFMT, TY_CHAR) + call salloc (tmproot, SZ_FNAME, TY_CHAR) + call salloc (tmpfile, SZ_FNAME, TY_CHAR) + + # Create the stack table + + call mktemp ("tmp$stk", Memc[tmproot], SZ_FNAME) + call tbtext (Memc[tmproot], Memc[tmpfile], SZ_FNAME) + stack = tbtopn (Memc[tmpfile], NEW_COPY, tp) + + # Set up column information that will not vary across columns + + Memc[colunits] = EOS + Memc[colfmt] = EOS + + # Add column names from the extra string + + ic = 1 + comma = ',' + repeat { + + # Copy the next comma delimeted column name + + jc = stridx (comma, extra[ic]) + if (jc == 0) + call strcpy (extra[ic], Memc[colname], SZ_COLNAME) + else + call strcpy (extra[ic], Memc[colname], jc-1) + ic = ic + jc + + # Create the new column + + if (Memc[colname] != EOS) + call tbcdef (stack, cp, Memc[colname], Memc[colunits], + Memc[colfmt], TY_INT, 1, 1) + + } until (jc == 0) + + # Return the stack table descriptor + + call tbtcre (stack) + call sfree (sp) + + return (stack) +end + +# FREESTACK -- Close and delete a table stack + +procedure freestack (tp) + +pointer tp # i: Table descriptor +#-- +pointer sp, table + +begin + call smark (sp) + call salloc (table, SZ_FNAME, TY_CHAR) + + call tbtnam (tp, Memc[table], SZ_FNAME) + call tbtclo (tp) + + call delete (Memc[table]) + call sfree (sp) +end + +# PUTSTACKT -- Put a text string in the top row of a table stack + +int procedure putstackt (tp, colname, colval) + +pointer tp # i: Table descriptor +char colname[ARB] # i: Column name +char colval[ARB] # i: Column value +#-- +int top, found +pointer cp + +int tbpsta() + +begin + top = tbpsta (tp, TBL_NROWS) + call tbcfnd (tp, colname, cp, 1) + + found = NO + if (cp != NULL) { + ifnoerr { + call tbrptt (tp, cp, colval, ARB, 1, top) + } then { + found = YES + } + } + + return (found) +end + +# PUTSTACKI -- Put an integer in the top row of a table stack + +procedure putstacki (tp, colname, colval) + +pointer tp # i: Table descriptor +char colname[ARB] # i: Column name +int colval # i: Column value +#-- +int top +pointer cp + +int tbpsta() + +begin + top = tbpsta (tp, TBL_NROWS) + + call tbcfnd (tp, colname, cp, 1) + call tbepti (tp, cp, top, colval) + +end + +# ANDSTACK -- Combine the top two rows of the table stack + +procedure andstack (tp) + +pointer tp # i: Table descriptor +#-- +int top +int tbpsta() + +begin + top = tbpsta (tp, TBL_NROWS) + + call movtbrow (tp, top, tp, top-1) + call tbrdel (tp, top, top) +end + +# MOVSTACK -- Move the top row of one table stack to another + +procedure movstack (rtp, wtp) + +pointer rtp # i: Table descriptor of table read from +pointer wtp # i: Table descriptor of table written to +#-- +int rtop, wtop + +int tbpsta() + +begin + call pushstack (wtp) + + rtop = tbpsta (rtp, TBL_NROWS) + wtop = tbpsta (wtp, TBL_NROWS) + + call movtbrow (rtp, rtop, wtp, wtop) + call tbrdel (rtp, rtop, rtop) + +end diff --git a/pkg/utilities/nttools/texpand/span.x b/pkg/utilities/nttools/texpand/span.x new file mode 100644 index 00000000..b8d69141 --- /dev/null +++ b/pkg/utilities/nttools/texpand/span.x @@ -0,0 +1,97 @@ +# SPAN -- Copy characters while they match a set +# +# B.Simon 25-Apr-88 Original + +int procedure span (set, str, ic, outstr, maxch) + +char set[ARB] # i: Set of characters used in matching +char str[ARB] # i: Input string +int ic # io: Index to input string character +char outstr[ARB] # o: Output string +int maxch # i: Maximum length of output string +#-- +bool match +int jc, kc, setlen + +int strlen() + +begin + # Loop over characters in the input string + + setlen = strlen (set) + for (jc = 1; str[ic] != EOS && jc <= maxch; ic = ic + 1) { + + # See if the current character in the input string + # matches the characters in the set + + match = false + do kc = 1, setlen { + if (str[ic] == set[kc]) { + match = true + break + } + } + + # Copy character to the output string if it matches + + if (! match) + break + + outstr[jc] = str[ic] + jc = jc + 1 + + } + + # Return number of characters in output string + + outstr[jc] = EOS + return (jc - 1) +end + +# NOSPAN -- Copy characters while they do not match a set + +int procedure nospan (set, str, ic, outstr, maxch) + +char set[ARB] # i: Set of characters used in matching +char str[ARB] # i: Input string +int ic # io: Index to input string character +char outstr[ARB] # o: Output string +int maxch # i: Maximum length of output string +#-- +bool match +int jc, kc, setlen + +int strlen() + +begin + # Loop over characters in the input string + + setlen = strlen (set) + for (jc = 1; str[ic] != EOS && jc <= maxch; ic = ic + 1) { + + # See if the current character in the input string + # matches the characters in the set + + match = false + do kc = 1, setlen { + if (str[ic] == set[kc]) { + match = true + break + } + } + + # Copy character to the output string if it does not match + + if (match) + break + + outstr[jc] = str[ic] + jc = jc + 1 + + } + + # Return number of characters in output string + + outstr[jc] = EOS + return (jc - 1) +end diff --git a/pkg/utilities/nttools/texpand/texpand.x b/pkg/utilities/nttools/texpand/texpand.x new file mode 100644 index 00000000..c89075c1 --- /dev/null +++ b/pkg/utilities/nttools/texpand/texpand.x @@ -0,0 +1,94 @@ +include + +# TEXPAND -- Expand the rows of a table according to a set of rules +# +# B.Simon 25-Apr-88 Original +# Phil Hodge 4-Oct-95 Use table name template routines tbnopenp, etc. + +procedure texpand () + +#-- +pointer ilist # Input file name template +pointer olist # Output file name template +pointer rbase # Name of file containing expansion rules +pointer debug # Debug file name +bool verbose # Diagnostic message flag + +int junk, dbg +pointer sp, itp, otp, input, output, target, action + +bool clgetb() +int open(), tbnlen(), tbnget() +pointer tbnopenp(), tbtopn() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (rbase, SZ_FNAME, TY_CHAR) + call salloc (debug, SZ_FNAME, TY_CHAR) + + # Read the parameter file + + ilist = tbnopenp ("input") + olist = tbnopenp ("output") + call clgstr ("rbase", Memc[rbase], SZ_FNAME) + call clgstr ("debug", Memc[debug], SZ_FNAME) + verbose = clgetb ("verbose") + + # Open debug file + + if (Memc[debug] == ' ' || Memc[debug] == EOS) + dbg = NULL + else + dbg = open (Memc[debug], NEW_FILE, TEXT_FILE) + + # Check to see that input & output templates + # have same number of files + + if (tbnlen (ilist) != tbnlen (olist)) + call error (ERR, "Number of input and output tables do not match") + + while (tbnget (ilist, Memc[input], SZ_FNAME) != EOF) { + + junk = tbnget (olist, Memc[output], SZ_FNAME) + + # Open input and output tables + + itp = tbtopn (Memc[input], READ_ONLY, NULL) + otp = tbtopn (Memc[output], NEW_COPY, itp) + call tbtcre (otp) + call tbhcal (itp, otp) + + # Create target and action tables from the rule base + + call parser (Memc[rbase], itp, dbg, target, action) + + # Expand the rows of the input table using the rules + # encoded in the target and action tables + + call use_rules (itp, otp, target, action, dbg, verbose) + + # Print diagnostic message and close tables + + if (verbose) { + call tbtnam (itp, Memc[input], SZ_FNAME) + call tbtnam (otp, Memc[output], SZ_FNAME) + + call printf ("%s -> %s\n") + call pargstr (Memc[input]) + call pargstr (Memc[output]) + call flush (STDOUT) + } + + call tbtclo (itp) + call tbtclo (otp) + } + + call close (dbg) + call tbnclose (ilist) + call tbnclose (olist) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/texpand/userules.x b/pkg/utilities/nttools/texpand/userules.x new file mode 100644 index 00000000..6195b148 --- /dev/null +++ b/pkg/utilities/nttools/texpand/userules.x @@ -0,0 +1,286 @@ +include + +# USE_RULES -- Use the rules to expand the input table rows +# +# B.Simon 25-Apr-88 Original +# B.Simon 21-Jan-99 Modified to handle empty target tables + +procedure use_rules (itp, otp, target, action, dbg, verbose) + +pointer itp # i: Input table +pointer otp # i: Output table +pointer target # u: Table of rule targets +pointer action # u: Table of rule actions +int dbg # i: Debug file descriptor +bool verbose # i: Print diagnostic message +#-- +int top, nrow, irow +pointer work + +int tbpsta() +int initstack(), numstack(), find_rule(), apply_rule() + +string tgtname "The following is the target table:" +string actname "The following is the action table:" +string isstart "The following row is read from the input table:" +string isdone "The following row is moved to the output table:" + +begin + # Do straight copy if target table is empty + + top = numstack (target) + if (top == 0) { + call no_rule (itp, otp) + return + } + + # Print target and action tables + + call dbg_rules (target, tgtname, 1, top, dbg) + + top = numstack (action) + call dbg_rules (action, actname, 1, top, dbg) + + # Create a work table, which is used to store + # intermediate results + + work = initstack (itp, "_TARGET,_INDEX") + + # Loop over each row in the input table + + nrow = tbpsta (itp, TBL_NROWS) + do irow = 1, nrow { + + call dbg_rules (itp, isstart, irow, irow, dbg) + + # Push the next row from the input table + # into the work table. If it does not match + # any rule, write it to the output table. + + call pushstack (work) + call movtbrow (itp, irow, work, 1) + if (find_rule (target, work) == 0) { + top = numstack (work) + call dbg_rules (work, isdone, top, top, dbg) + call movstack (work, otp) + } + + # Apply the next instance of the rule to the + # row on top of the stack. If the result of the + # application of the rule does not match any other + # rule, write it to the output table. + + while (numstack (work) > 0) { + if (apply_rule (target, action, work, dbg) == 0) { + top = numstack (work) + call dbg_rules (work, isdone, top, top, dbg) + call movstack (work, otp) + if (verbose && mod (numstack (otp), 25) == 0) { + call printf ("\r%d rows written to output table") + call pargi (numstack (otp)) + call flush (STDOUT) + } + } + } + } + + if (verbose) { + call printf ("\r%39w\r") + call flush (STDOUT) + } + + call freestack (target) + call freestack (action) + call freestack (work) +end + +# APPLY_RULE -- Expand the top work table row according to a rule + +int procedure apply_rule (target, action, work, dbg) + +pointer target # i: Table of rule targets +pointer action # i: Table of rule actions +pointer work # i: Table of intermediate results +int dbg # i: Debug file descriptor +#-- +int wrow, trow, arow, last, rule +pointer tgt_ptr, idx_ptr, lst_ptr, use_ptr + +string isrule "The following rule is applied:" +string notdone "To produce the row:" + +int numstack(), find_rule() + +begin + # Get column pointers of special columns + + call tbcfnd (work, "_TARGET", tgt_ptr, 1) + call tbcfnd (work, "_INDEX", idx_ptr, 1) + call tbcfnd (target, "_LAST", lst_ptr, 1) + + # Get the current row numbers for the work, target, + # and action tables + + wrow = numstack (work) + call tbegti (work, tgt_ptr, wrow, trow) + call tbegti (work, idx_ptr, wrow, arow) + call tbegti (target, lst_ptr, trow, last) + + # If the action row number is greater than the last action + # associated with the target, all the expansions for this + # rule have been performed. Pop the work table and mark the + # target row as unused. + + if (arow > last) { + call popstack (work) + call tbcfnd (target, "_USED", use_ptr, 1) + call tbepti (target, use_ptr, trow, NO) + rule = trow + + # Otherwise, duplicate the top row of the work table and + # overwrite the appropriate columns with the values stored + # in the action row. Increment the action row for next time. + # Initialize the special columns in the new row of the work + # table. + + } else { + call pushstack (work) + call movtbrow (work, wrow, work, wrow+1) + call movtbrow (action, arow, work, wrow+1) + call tbepti (work, idx_ptr, wrow, arow+1) ## should be wrow+1 ?? + call dbg_rules (target, isrule, trow, trow, dbg) + call dbg_rules (work, notdone, wrow+1, wrow+1, dbg) + rule = find_rule (target, work) + } + + return (rule) +end + +# FIND_RULE -- Find the target row which matches the top work table row + +int procedure find_rule (target, work) + +pointer target # i: Table of rule targets +pointer work # i: Table of intermediate results +#-- +bool match, nullflg +int icol, jcol, tcol, wcol, trow, irow, wrow, used, first +pointer sp, tarptr, wrkptr, colname, tarval, wrkval +pointer use_ptr, fst_ptr, tgt_ptr, idx_ptr, iw + +bool strne() +int tbpsta(), strlen() +pointer tbcnum(), numstack() + +begin + # Get number of columns in tables + + tcol = tbpsta (target, TBL_NCOLS) + wcol = tbpsta (work, TBL_NCOLS) + + # Allocate dynamic memory + + call smark (sp) + call salloc (tarptr, tcol, TY_INT) + call salloc (wrkptr, tcol, TY_INT) + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (tarval, SZ_LINE, TY_CHAR) + call salloc (wrkval, SZ_LINE, TY_CHAR) + + # Create arrays of corresponding column pointers + # in the target and work tables + + jcol = 0 + do icol = 1, tcol { + Memi[tarptr+jcol] = tbcnum (target, icol) + call tbcigt (Memi[tarptr+jcol), TBL_COL_NAME, + Memc[colname], SZ_COLNAME) + call tbcfnd (work, Memc[colname], Memi[wrkptr+jcol], 1) + if (Memc[colname] != '_' && Memi[wrkptr+jcol] != NULL) + jcol = jcol + 1 + } + + # Get pointers to special columns + + call tbcfnd (target, "_USED", use_ptr, 1) + call tbcfnd (target, "_FIRST", fst_ptr, 1) + call tbcfnd (work, "_TARGET", tgt_ptr,1) + call tbcfnd (work, "_INDEX", idx_ptr, 1) + + # Search for a match in the target table + # with the top row of the work table + + match = false + wrow = numstack (work) + trow = tbpsta (target, TBL_NROWS) + do irow = 1, trow { + + call tbegti (target, use_ptr, irow, used) + if (used == NO) { + + # Compare each non-null column of the target row + # to the work row + + match = true + do icol = 1, jcol { + call tbrgtt (target, Memi[tarptr+icol-1], Memc[tarval], + nullflg, SZ_LINE, 1, irow) + + if (! nullflg) { + call tbegtt (work, Memi[wrkptr+icol-1], wrow, + Memc[wrkval], SZ_LINE) + + iw = strlen (Memc[wrkval]) + wrkval - 1 + while (Memc[iw] == ' ') + iw = iw - 1 + Memc[iw+1] = EOS + + if (strne (Memc[tarval], Memc[wrkval])) { + match = false + break + } + } + } + + # If the rows match, mark the target row as used + # and initialize the special columns in the work row + + if (match) { + + call tbepti (target, use_ptr, irow, YES) + + call tbegti (target, fst_ptr, irow, first) + call tbepti (work, idx_ptr, wrow, first) + call tbepti (work, tgt_ptr, wrow, irow) + + break + } + } + } + + call sfree (sp) + + # If a match was found, return the target row number matched + + if (match) + return (irow) + else + return (0) +end + +# NO_RULE -- Do a straight copy when ther are no expansion rules + +procedure no_rule (itp, otp) + +pointer itp # i: Input table +pointer otp # i: Output table +#-- +int irow, nrow +int tbpsta() + +begin + nrow = tbpsta (itp, TBL_NROWS) + + do irow = 1, nrow + call tbrcpy (itp,otp, irow, irow) +end diff --git a/pkg/utilities/nttools/texpand/x_texpand.x b/pkg/utilities/nttools/texpand/x_texpand.x new file mode 100644 index 00000000..37d7f51e --- /dev/null +++ b/pkg/utilities/nttools/texpand/x_texpand.x @@ -0,0 +1,3 @@ +# X_TEXPAND -- Dummy main routine for texpand + +task texpand = texpand diff --git a/pkg/utilities/nttools/thedit.par b/pkg/utilities/nttools/thedit.par new file mode 100644 index 00000000..fe981799 --- /dev/null +++ b/pkg/utilities/nttools/thedit.par @@ -0,0 +1,7 @@ +table,s,a,"",,,tables to be edited +keywords,s,a,"",,,keywords to be edited +value,s,a,".",,,value expression +delete,b,h,no,,,delete rather than edit keywords? +show,b,h,yes,,,print record of each edit operation? +Version,s,h,"8Sept2000",,,"date of installation" +mode,s,h,"al" diff --git a/pkg/utilities/nttools/thedit/mkpkg b/pkg/utilities/nttools/thedit/mkpkg new file mode 100644 index 00000000..5b9e150a --- /dev/null +++ b/pkg/utilities/nttools/thedit/mkpkg @@ -0,0 +1,13 @@ +# Update thedit in the ttools package library. +# Author: HODGE, 10-MAY-2000 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + t_thedit.x + t_thselect.x + tkw.x + ; diff --git a/pkg/utilities/nttools/thedit/t_thedit.x b/pkg/utilities/nttools/thedit/t_thedit.x new file mode 100644 index 00000000..3fac69de --- /dev/null +++ b/pkg/utilities/nttools/thedit/t_thedit.x @@ -0,0 +1,833 @@ +include +include +include +include +include + +define SZ_TABLENAME (SZ_FNAME) # max size of a table name +define SZ_KEYWORDNAME 31 # max size of a keyword name + +define OP_EDIT 1 # hedit opcodes +define OP_DELETE 2 +define OP_PRINT 3 + + +# thedit -- Edit or view selected keywords of a table header or headers. This +# editor performs a single edit operation upon a relation, e.g., upon a set +# of keywords of a set of tables. Templates and expressions may be used to +# automatically select the tables and keywords to be edited, and to compute +# the new value of each keyword. +# +# Phil Hodge, 10-May-2000 Task created, based on hedit. +# Phil Hodge, 26-May-2000 When adding a keyword, check for invalid characters. +# Phil Hodge, 31-May-2000 Add "keywords" i_nrows, etc. +# Phil Hodge, 19-Jul-2000 In he_getop, call tkw_special before tbhgtt, +# rather than explicitly checking for $I. +# Phil Hodge, 8-Sep-2000 Require value = "\." or "\," in order to actually +# set a keyword value to "." or ",". ("\," is for protection +# against accidentally typing "," instead of ".".) +# In he_add_keyword, include the new value in the message +# (if show=yes). In he_put_keyword, include both the old and +# new values in the message. +# Phil Hodge, 4-Mar-2002 Call xev_freeop to free memory allocated by evexpr. +# Phil Hodge, 1-Apr-2003 Fix incorrect calling sequence for tkw_open +# in he_delete. + +procedure t_thedit() + +pointer keywords # template listing keywords to be processed +pointer valexpr # the value expression (if op=edit|add) + +pointer tnt +pointer sp, s_valexpr, table, template, buf +pointer tp # pointer to table struct +pointer kw # pointer to table keyword struct +pointer vip # for deleting whitespace in valexpr +pointer newval # valexpr after evaluation +int operation, show +int ip, ctowrd() +int nkw, tkw_len() # number of keywords that match the template +int dtype # data type of expression + +pointer tbtopn() +pointer tkw_open() +bool clgetb(), streq() +bool tbhisc() +int btoi(), tbnopenp(), tbnget() +int i, strlen() +errchk he_print, he_delete, he_add_keyword, he_put_keyword, he_evaluate + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + call salloc (table, SZ_FNAME, TY_CHAR) + call salloc (keywords, SZ_LINE, TY_CHAR) + call salloc (template, SZ_FNAME, TY_CHAR) + call salloc (s_valexpr, SZ_LINE, TY_CHAR) + call salloc (newval, SZ_LINE, TY_CHAR) + + # Get the list of table names. + tnt = tbnopenp ("table") + + # Determine type of operation to be performed. The default operation + # is edit. + + operation = OP_EDIT + if (clgetb ("delete")) + operation = OP_DELETE + + # Get list of keywords to be edited, added, or deleted. + call clgstr ("keywords", Memc[keywords], SZ_LINE) + do i = 1, strlen (Memc[keywords]) { + if (Memc[keywords+i-1] == ',') + Memc[keywords+i-1] = ' ' # replace comma with blank + } + + # The value expression parameter is not used for the delete operation. + if (operation != OP_DELETE) { + call clgstr ("value", Memc[s_valexpr], SZ_LINE) + for (vip=s_valexpr; IS_WHITE (Memc[vip]); vip=vip+1) + ; + valexpr = vip + while (Memc[vip] != EOS) + vip = vip + 1 + while (vip > valexpr && IS_WHITE (Memc[vip-1])) + vip = vip - 1 + Memc[vip] = EOS + } else { + Memc[s_valexpr] = EOS + valexpr = s_valexpr + } + # Check for value = ",", which could be a typo. + if (streq (Memc[valexpr], ",")) { + call error (1, + "In order to set a keyword value to ',' you must use value='\,'") + } else if (streq (Memc[valexpr], "\,")) { + call strcpy (",", Memc[valexpr], SZ_LINE) + } + + # Get switches. If the expression value is ".", meaning print value + # rather than edit, then we do not use the switches. + + if (streq (Memc[valexpr], ".")) { + operation = OP_PRINT + show = NO + } else { + show = btoi (clgetb ("show")) + } + + # In order to set the keyword value to ".", specify value="\.". + if (streq (Memc[valexpr], "\.")) + call strcpy (".", Memc[valexpr], SZ_LINE) + + # Main processing loop. A table is processed in each pass through + # the loop. + + while (tbnget (tnt, Memc[table], SZ_FNAME) != EOF) { + + # Open the current table. + iferr { + if (operation == OP_PRINT) + tp = tbtopn (Memc[table], READ_ONLY, NULL) + else + tp = tbtopn (Memc[table], READ_WRITE, NULL) + } then { + call erract (EA_WARN) + next + } + + # Get a list of all the keywords in the header. + kw = tkw_open (tp) + + # for each keyword or template in blank-separated list ... + ip = 1 + while (ctowrd (Memc[keywords], ip, Memc[template], SZ_FNAME) > 0) { + + # Find all keywords that match the current keyword template. + call tkw_find (tp, kw, Memc[template]) + nkw = tkw_len (kw) + + if (operation == OP_PRINT) { + + call he_print (tp, kw, Memc[table], Memc[template]) + + } else if (operation == OP_DELETE) { + + call he_delete (tp, kw, Memc[table], Memc[template], show) + + } else { + + # interpret the value string + call he_getopsettable (tp, Memc[table], Memc[template]) + call he_evaluate (Memc[valexpr], + Memc[newval], SZ_LINE, dtype) + + # No keywords match the template, or the keyword is + # history or comment? + if (nkw == 0 || tbhisc (Memc[template])) { + + # Add a new keyword. + call he_add_keyword (tp, Memc[table], Memc[template], + Memc[newval], dtype, show) + + } else { + + call he_put_keyword (tp, kw, Memc[table], + Memc[template], Memc[newval], dtype, show) + } + } + } + + # Close the keyword list and the table. + call tkw_close (kw) + call tbtclo (tp) + + call flush (STDOUT) + } + + call tbnclose (tnt) + call sfree (sp) +end + + +# This routine prints the value of the keyword or keywords that match +# the template. + +procedure he_print (tp, kw, table, template) + +pointer tp # i: pointer to table struct +pointer kw # i: pointer to keyword struct +char table[ARB] # i: table name +char template[ARB] # i: keyword name or template (for warning message) +#-- +pointer sp +pointer value, comment +char keyword[SZ_KEYWORD] # keyword name +int nkw # number of keywords +int k +int tkw_len() + +begin + nkw = tkw_len (kw) + + if (nkw == 0) { + call eprintf ("Warning: keyword(s) `%s' not found.\n") + call pargstr (template) + } else { + call smark (sp) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (comment, SZ_FNAME, TY_CHAR) + do k = 1, nkw { + call he_gval (tp, kw, k, + keyword, Memc[value], Memc[comment], SZ_FNAME) + call printf ("%s,%s = %s") + call pargstr (table) + call pargstr (keyword) + call he_pargstr (Memc[value]) + if (Memc[comment] != EOS) { + call printf (" / %s") + call pargstr (Memc[comment]) + } + call printf ("\n") + } + call sfree (sp) + } +end + +procedure he_gval (tp, kw, k, keyword, value, comment, maxch) + +pointer tp # i: pointer to table struct +pointer kw # i: pointer to keyword struct +int k # i: index in list of matched keywords +char keyword[SZ_KEYWORD] # o: keyword name +char value[ARB] # o: value of keyword +char comment[ARB] # o: comment, or null +int maxch # i: size of value and comment strings +#-- +pointer sp +pointer sval +int i +int keynum # index in list of all keywords in header +int dtype # data type of keyword +bool tbhisc() +errchk tbhgnp, tbhgcm, tkw_special + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call tkw_getkw (kw, k, keynum, keyword, SZ_KEYWORD) + + if (keynum > 0) { + + call tbhgnp (tp, keynum, keyword, dtype, Memc[sval]) + + # Delete leading whitespace. + do i = 0, SZ_FNAME-1 { + if (Memc[sval+i] == EOS) + break + if (!IS_WHITE(Memc[sval+i])) + break + } + call strcpy (Memc[sval+i], value, maxch) + + if (tbhisc (keyword)) + comment[1] = EOS + else + call tbhgcm (tp, keyword, comment, maxch) + + } else { + + call tkw_special (tp, keyword, value, maxch) + comment[1] = EOS + } + + call sfree (sp) +end + +# This routine deletes one or more keywords from the header. +# The list of all keywords in the header and the list of keywords that +# match the template will be reassigned after deleting. + +procedure he_delete (tp, kw, table, template, show) + +pointer tp # i: pointer to table struct +pointer kw # io: pointer to keyword struct +char table[ARB] # i: table name +char template[ARB] # i: keyword name or template +int show # i: print info? +#-- +char keyword[SZ_KEYWORD] # keyword name +int nkw # number of keywords +int keynum # index in list of all keywords in header +int k +pointer tkw_open() +int tkw_len() +errchk tbhdel + +begin + nkw = tkw_len (kw) + + if (nkw == 0) { + call eprintf ("Warning: keyword(s) `%s' not found.\n") + call pargstr (template) + } else { + + do k = nkw, 1, -1 { + call tkw_getkw (kw, k, keynum, keyword, SZ_KEYWORD) + if (keynum <= 0) { + call eprintf ( + "Warning: can't delete special keyword %s.\n") + call pargstr (keyword) + next + } + call tbhdel (tp, keynum) + if (show == YES) { + call printf ("%s,%s deleted\n") + call pargstr (table) + call pargstr (keyword) + } + } + + # Update the list of the current keywords, since we've deleted some. + call tkw_close (kw) + kw = tkw_open (tp) + } +end + +# This routine adds a new keyword to the header. + +procedure he_add_keyword (tp, table, keyword, newval, dtype, show) + +pointer tp # i: pointer to table struct +char table[ARB] # i: table name +char keyword[ARB] # i: keyword name or template +char newval[ARB] # i: value to assign to keyword +int dtype # i: data type of newval +int show # i: print info? +#-- +int i +bool bval +int ival +real rval +double dval +int nscan() +errchk tbhadd, tbhadr, tbhadi, tbhadb, tbhadt + +begin + # Check that the keyword name is valid. + do i = 1, SZ_KEYWORD { + + if (keyword[i] == EOS) + break + + if (keyword[i] == '*' || keyword[i] == '?') { + call eprintf ( + "Warning: keyword `%s' doesn't match any keyword in the header;\n") + call pargstr (keyword) + call eprintf (" this keyword template will be ignored.\n") + return + } + + # All the following are OK: + if (IS_UPPER(keyword[i])) + next + if (IS_LOWER(keyword[i])) + next + if (IS_DIGIT(keyword[i])) + next + if (keyword[i] == '_' || keyword[i] == '-') + next + + # If we get here, the character is invalid. + call eprintf ("Warning: invalid character `%c' in keyword `%s';\n") + call pargc (keyword[i]) + call pargstr (keyword) + call eprintf (" this keyword will not be added to the header.\n") + return + } + + switch (dtype) { + case TY_DOUBLE: + call sscan (newval) + call gargd (dval) + if (nscan() < 1) { + call eprintf ("can't interpret %s as a floating point value\n") + call pargstr (newval) + call error (1, "") + } + call tbhadd (tp, keyword, dval) + + case TY_REAL: + call sscan (newval) + call gargr (rval) + if (nscan() < 1) { + call eprintf ("can't interpret %s as a floating point value\n") + call pargstr (newval) + call error (1, "") + } + call tbhadr (tp, keyword, rval) + + case TY_INT: + call sscan (newval) + call gargi (ival) + if (nscan() < 1) { + call eprintf ("can't interpret %s as an integer\n") + call pargstr (newval) + call error (1, "") + } + call tbhadi (tp, keyword, ival) + + case TY_BOOL: + call sscan (newval) + call gargb (bval) + if (nscan() < 1) { # shouldn't happen + call eprintf ("can't interpret %s as a boolean value\n") + call pargstr (newval) + call error (1, "") + } + call tbhadb (tp, keyword, bval) + + default: + call tbhadt (tp, keyword, newval) + } + + if (show == YES) { + call printf ("add %s,%s = %s\n") + call pargstr (table) + call pargstr (keyword) + call he_pargstr (newval) + } +end + +procedure he_put_keyword (tp, kw, table, template, newval, dtype, show) + +pointer tp # i: pointer to table struct +pointer kw # i: pointer to keyword struct +char table[ARB] # i: table name +char template[ARB] # i: keyword name or template +char newval[ARB] # i: value to assign to keyword +int dtype # i: data type of newval +int show # i: print info? +#-- +bool bval +int ival +real rval +double dval +char oldval[SZ_FNAME] # current value of keyword (if show is YES) +char keyword[SZ_KEYWORD] # name of current keyword +int keynum # index in list of all keywords in header +int k +int nkw, tkw_len() +int nscan() +errchk tbhptd, tbhptr, tbhpti, tbhptb, tbhptt + +begin + nkw = tkw_len (kw) + + # for each keyword that matches the template ... + do k = 1, nkw { + + call tkw_getkw (kw, k, keynum, keyword, SZ_KEYWORD) + if (keynum <= 0) { + call eprintf ("Warning: can't modify special keyword %s.\n") + call pargstr (keyword) + next + } + + if (show == YES) { # get the current value + call tbhgtt (tp, keyword, oldval, SZ_FNAME) + } + + switch (dtype) { + case TY_DOUBLE: + call sscan (newval) + call gargd (dval) + if (nscan() < 1) { + call eprintf ( + "can't interpret %s as a floating point value\n") + call pargstr (newval) + call error (1, "") + } + call tbhptd (tp, keyword, dval) + + case TY_REAL: + call sscan (newval) + call gargr (rval) + if (nscan() < 1) { + call eprintf ( + "can't interpret %s as a floating point value\n") + call pargstr (newval) + call error (1, "") + } + call tbhptr (tp, keyword, rval) + + case TY_INT: + call sscan (newval) + call gargi (ival) + if (nscan() < 1) { + call eprintf ("can't interpret %s as an integer\n") + call pargstr (newval) + call error (1, "") + } + call tbhadi (tp, keyword, ival) + + case TY_BOOL: + call sscan (newval) + call gargb (bval) + if (nscan() < 1) { # shouldn't happen + call eprintf ("can't interpret %s as a boolean value\n") + call pargstr (newval) + call error (1, "") + } + call tbhadb (tp, keyword, bval) + + default: + call tbhptt (tp, keyword, newval) + } + + if (show == YES) { + call printf ("%s,%s updated: %s -> %s\n") + call pargstr (table) + call pargstr (keyword) + call he_pargstr (oldval) + call he_pargstr (newval) + } + } +end + +# This routine copies the value from valexpr to newval and interprets +# the data type of the result. If valexpr begins with "(", it will be +# passed to evexpr to evaluate it, and the resulting string will be +# returned as newval. + +procedure he_evaluate (valexpr, newval, maxch, dtype) + +char valexpr[ARB] # i: value expression +char newval[ARB] # o: value +int maxch # i: size of newval +int dtype # o: data type of expression +#-- +pointer o # evexpr pointer +pointer evexpr() +int locpr() +bool streq() +int he_dtype() +extern he_getop() + +begin + if (streq (valexpr, ".")) { + + call strcpy (valexpr, newval, maxch) + dtype = TY_CHAR # irrelevant + + } else if (valexpr[1] == '(') { + + # Evaluate the expression given in parentheses. + o = evexpr (valexpr, locpr (he_getop), 0) + + switch (O_TYPE(o)) { # evexpr only supports these data types + case TY_BOOL: + dtype = TY_BOOL + call sprintf (newval, maxch, "%b") + call pargb (O_VALB(o)) + case TY_CHAR: + dtype = TY_CHAR + call sprintf (newval, maxch, "%s") + call pargstr (O_VALC(o)) + case TY_INT: + dtype = TY_INT + call sprintf (newval, maxch, "%d") + call pargi (O_VALI(o)) + case TY_REAL: + dtype = TY_REAL + call sprintf (newval, maxch, "%g") + call pargr (O_VALR(o)) + default: + call error (1, "unknown expression datatype") + } + call xev_freeop (o) + call mfree (o, TY_STRUCT) + + } else { + + # Interpret the data type, and copy the string from valexpr to + # newval. + dtype = he_dtype (valexpr, newval, maxch) + } +end + +# This function returns the data type of value, and it copies value to +# newval. If the data type is boolean, don't complain if the user gave +# the value in a nonstandard form, such as "T" or "F", but then assign +# the standard "yes" or "no" to newval (that's the reason for copying +# value to newval). + +int procedure he_dtype (value, newval, maxch) + +char value[ARB] # i: the value encoded as a string +char newval[ARB] # o: same as lower case value, unless type is boolean +int maxch # i: max size of newval +#-- +int dtype # the data type, to be returned +bool numeric +int tok_type, ip, numlen +int lexnum() +int strlen() +bool streq() + +begin + # Use newval for scratch, to convert to lower case for the + # tests on boolean data type. + call strcpy (value, newval, maxch) + call strlwr (newval) + + if (streq (newval, "yes") || + streq (newval, "true") || + streq (newval, "t")) { + + dtype = TY_BOOL + + call strcpy ("yes", newval, maxch) + + } else if (streq (newval, "no") || + streq (newval, "false") || + streq (newval, "f")) { + + dtype = TY_BOOL + + call strcpy ("no", newval, maxch) + + } else { + + ip = 1 + tok_type = lexnum (value, ip, numlen) + numeric = (tok_type != LEX_NONNUM && numlen == strlen (value)) + + if (numeric) { + if (tok_type == LEX_OCTAL || tok_type == LEX_DECIMAL || + tok_type == LEX_HEX) { + dtype = TY_INT + } else if (tok_type == LEX_REAL) { + dtype = TY_DOUBLE + } else { + dtype = TY_CHAR # shouldn't happen + } + } else { + dtype = TY_CHAR + } + + call strcpy (value, newval, maxch) + } + + return (dtype) +end + +# HE_GETOP -- Satisfy an operand request from EVEXPR. The value of the +# current keyword is gotten from the table header. +# +# Note that HE_GETOPSETTABLE must first have been called to save the +# table pointer and keyword name in the common block. + +procedure he_getop (operand, o) + +char operand[ARB] # operand name +pointer o # operand (output) + +pointer sp +pointer keyword # scratch for current keyword name +pointer value # scratch for value +pointer newvalue # value in lower case; "yes" or "no" for bool value +int dtype # data type of keyword +pointer h_tp # getop common +char h_table[SZ_TABLENAME] +char h_keyword[SZ_KEYWORDNAME] +common /hegop2/ h_tp, h_table, h_keyword +int he_dtype() +bool streq() +errchk tbhgtt + +begin + call smark (sp) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (newvalue, SZ_FNAME, TY_CHAR) + call salloc (keyword, SZ_KEYWORDNAME, TY_CHAR) + + if (streq (operand, "$")) + call strcpy (h_keyword, Memc[keyword], SZ_KEYWORDNAME) + else + call strcpy (operand, Memc[keyword], SZ_KEYWORDNAME) + + # Get the value and interpret its data type. + iferr { + call tkw_special (h_tp, Memc[keyword], Memc[value], SZ_FNAME) + } then { + call tbhgtt (h_tp, Memc[keyword], Memc[value], SZ_FNAME) + } + + dtype = he_dtype (Memc[value], Memc[newvalue], SZ_FNAME) + + switch (dtype) { + case TY_BOOL: + call xev_initop (o, 0, TY_BOOL) + O_VALB(o) = (streq (Memc[newvalue], "yes")) + + case TY_SHORT, TY_INT, TY_LONG: + call xev_initop (o, 0, TY_INT) + call sscan (Memc[value]) + call gargi (O_VALI(o)) + + case TY_REAL, TY_DOUBLE, TY_COMPLEX: + call xev_initop (o, 0, TY_REAL) + call sscan (Memc[value]) + call gargr (O_VALR(o)) + + default: + call xev_initop (o, SZ_LINE, TY_CHAR) + call strcpy (Memc[value], O_VALC(o), SZ_LINE) + } + + call sfree (sp) +end + + +# HE_GETOPSETTABLE -- Copy the table pointer, table name, and keyword name +# to a common block in preparation for a getop call by EVEXPR. + +procedure he_getopsettable (tp, table, keyword) + +pointer tp # table descriptor of table to be edited +char table[ARB] # name of table to be edited +char keyword[ARB] # name of keyword to be edited + +pointer h_tp # getop common +char h_table[SZ_TABLENAME] +char h_keyword[SZ_KEYWORDNAME] +common /hegop2/ h_tp, h_table, h_keyword + +begin + h_tp = tp + call strcpy (table, h_table, SZ_TABLENAME) + call strcpy (keyword, h_keyword, SZ_KEYWORDNAME) +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/utilities/nttools/thedit/t_thselect.x b/pkg/utilities/nttools/thedit/t_thselect.x new file mode 100644 index 00000000..db6f9077 --- /dev/null +++ b/pkg/utilities/nttools/thedit/t_thselect.x @@ -0,0 +1,150 @@ +include +include +include +include + +define SZ_TABLENAME (SZ_FNAME) # max size of a table name +define SZ_KEYWORDNAME 31 # max size of a keyword name + + +# thselect -- Print table keyword values, if the specified expression is true. +# +# Phil Hodge, 19-Jul-2000 Task created, based on hselect. +# Phil Hodge, 4-Mar-2002 Free memory allocated by evexpr. + +procedure t_thselect() + +pointer keywords # template listing keywords to be processed +pointer expr # boolean expression to be evaluated + +pointer tnt +pointer sp, table +pointer tp # pointer to table struct +int i + +pointer tbtopn() +int tbnopenp(), tbnget() +int strlen() +errchk he_select + +begin + call smark (sp) + call salloc (table, SZ_FNAME, TY_CHAR) + call salloc (keywords, SZ_LINE, TY_CHAR) + call salloc (expr, SZ_LINE, TY_CHAR) + + # Get the list of table names. + tnt = tbnopenp ("table") + + # Get the list of keyword names. + call clgstr ("keywords", Memc[keywords], SZ_LINE) + do i = 1, strlen (Memc[keywords]) { + if (Memc[keywords+i-1] == ',') + Memc[keywords+i-1] = ' ' # replace comma with blank + } + + # Get the boolean expression. + call clgstr ("expr", Memc[expr], SZ_LINE) + + # Main processing loop. A table is processed in each pass through + # the loop. + + while (tbnget (tnt, Memc[table], SZ_FNAME) != EOF) { + + # Open the current table. + iferr { + tp = tbtopn (Memc[table], READ_ONLY, NULL) + } then { + call erract (EA_WARN) + next + } + + # Get the full table name (including extension if FITS). + call tbtnam (tp, Memc[table], SZ_FNAME) + + call he_getopsettable (tp, Memc[table], Memc[keywords]) + + iferr { + call hs_select (tp, Memc[table], Memc[keywords], Memc[expr]) + } then { + call erract (EA_WARN) + call tbtclo (tp) + next + } + + call tbtclo (tp) + } + + call tbnclose (tnt) + call sfree (sp) +end + +procedure hs_select (tp, table, keywords, expr) + +pointer tp # i: pointer to table struct +char table[ARB] # i: name of current table +char keywords[ARB] # i: blank-separated list of keyword names +char expr[ARB] # i: boolean expression +#-- +pointer sp +pointer template # one keyword name (may include wildcard characters) +pointer value, comment +char keyword[SZ_KEYWORD] # current keyword name +pointer o +pointer evexpr() +int locpr() +extern he_getop() +pointer kw, tkw_open() +int ip, ctowrd() +int nkw # number of keywords +int k # loop index in list of matched keywords +int tkw_len() +bool first # true if first keyword (template) in keywords +errchk evexpr + +begin + call smark (sp) + call salloc (template, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (comment, SZ_FNAME, TY_CHAR) + + # Evaluate the boolean expression. + 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 keywords if the expression is true. + if (O_VALB(o)) { + + # Get a list of all the keywords in the header. + kw = tkw_open (tp) + + # for each keyword or template in blank-separated list ... + ip = 1 + first = true + while (ctowrd (keywords, ip, Memc[template], SZ_FNAME) > 0) { + + # Find all keywords that match the current keyword template. + call tkw_find (tp, kw, Memc[template]) + nkw = tkw_len (kw) + + # Get and print the keyword values. + do k = 1, nkw { + call he_gval (tp, kw, k, + keyword, Memc[value], Memc[comment], SZ_FNAME) + if (!first) + call printf ("\t") + call printf ("%s") + call he_pargstr (Memc[value]) + first = false + } + } + call printf ("\n") + call flush (STDOUT) + call tkw_close (kw) + } + + call xev_freeop (o) + call mfree (o, TY_STRUCT) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/thedit/tkw.x b/pkg/utilities/nttools/thedit/tkw.x new file mode 100644 index 00000000..9cb9d371 --- /dev/null +++ b/pkg/utilities/nttools/thedit/tkw.x @@ -0,0 +1,405 @@ +include +include # for file creation or modification time +include +include + +# This file contains a set of routines for finding header keywords in a +# table. +# +# kw = tkw_open (tp) +# call tkw_close (kw) +# call tkw_find (tp, kw, keyword) +# nkw = tkw_len (kw) +# call tkw_reopen (tp, kw, keyword) +# call tkw_getkw (kw, k, keynum, keyword, maxch) +# call tkw_special (tp, keyword, value, maxch) +# +# Phil Hodge, 10-May-2000 Subroutines created. +# Phil Hodge, 31-May-2000 Add "keywords" i_nrows, etc. +# Phil Hodge, 19-Jul-2000 Add support for $I (equivalent to i_table). +# Phil Hodge, 15-Jul-2009 Remove ttype from calling sequence for tbparse. + +define NUM_SPECIAL 7 # number of keywords such as i_nrows +define N_I_TABLE 1 # index number for i_table +define N_I_FILE 2 # index number for i_file +define N_I_CTIME 3 +define N_I_NROWS 4 +define N_I_NCOLS 5 +define N_I_NPAR 6 +define N_I_TYPE 7 + +define SZ_KW_LIST 5 +define SZ_KW_SPACING (SZ_KEYWORD+2) # spacing of keywords in KW_NAME + +define NUM_KEYWORDS Memi[$1] # total number of keywords +define NUM_MATCH Memi[$1+1] # number of keywords that match template +define KW_NAME_PTR Memi[$1+2] # list of keyword names +define KW_TYPE_PTR Memi[$1+3] # list of keyword data types +define KW_MATCH_PTR Memi[$1+4] # indexes of keywords matching template +define KW_NAME Memc[KW_NAME_PTR($1) + ($2-1)*SZ_KW_SPACING] +define KW_TYPE Memi[KW_TYPE_PTR($1) + $2-1] +define KW_MATCH Memi[KW_MATCH_PTR($1) + $2-1] + +# get list of all keywords in header + +pointer procedure tkw_open (tp) + +pointer tp # i: pointer to table struct +#-- +pointer kw # o: pointer to keyword list struct +char keyword[SZ_KEYWORD] # current keyword +int dtype # data type of current keyword +char value[SZ_PARREC] # value of current keyword +int i +int npar # number of keywords excluding i_nrows, etc +int keynum # index for keyword number +int tbpsta() +errchk tbhgnp + +begin + call malloc (kw, SZ_KW_LIST, TY_POINTER) + + npar = tbpsta (tp, TBL_NPAR) + + NUM_KEYWORDS(kw) = NUM_SPECIAL + npar + NUM_MATCH(kw) = 0 # initial value + + call calloc (KW_NAME_PTR(kw), + SZ_KW_SPACING * NUM_KEYWORDS(kw), TY_CHAR) + + call calloc (KW_TYPE_PTR(kw), NUM_KEYWORDS(kw), TY_INT) + call calloc (KW_MATCH_PTR(kw), NUM_KEYWORDS(kw), TY_INT) + + # First assign names for the special keywords i_nrows, etc. + # This list must agree with those in tkw_special, and the + # number of such keywords must be no larger than NUM_SPECIAL. + + call strcpy ("i_table", KW_NAME(kw,N_I_TABLE), SZ_KEYWORD) + KW_TYPE(kw,N_I_TABLE) = TY_CHAR + + call strcpy ("i_file", KW_NAME(kw,N_I_FILE), SZ_KEYWORD) + KW_TYPE(kw,N_I_FILE) = TY_INT + + call strcpy ("i_ctime", KW_NAME(kw,N_I_CTIME), SZ_KEYWORD) + KW_TYPE(kw,N_I_CTIME) = TY_INT + + call strcpy ("i_nrows", KW_NAME(kw,N_I_NROWS), SZ_KEYWORD) + KW_TYPE(kw,N_I_NROWS) = TY_INT + + call strcpy ("i_ncols", KW_NAME(kw,N_I_NCOLS), SZ_KEYWORD) + KW_TYPE(kw,N_I_NCOLS) = TY_INT + + call strcpy ("i_npar", KW_NAME(kw,N_I_NPAR), SZ_KEYWORD) + KW_TYPE(kw,N_I_NPAR) = TY_INT + + call strcpy ("i_type", KW_NAME(kw,N_I_TYPE), SZ_KEYWORD) + KW_TYPE(kw,N_I_TYPE) = TY_CHAR + + keynum = 1 + do i = NUM_SPECIAL+1, NUM_KEYWORDS(kw) { + + call tbhgnp (tp, keynum, keyword, dtype, value) + call strcpy (keyword, KW_NAME(kw,i), SZ_KEYWORD) + KW_TYPE(kw,i) = dtype + keynum = keynum + 1 + } + + return (kw) +end + +# free memory for keyword list + +procedure tkw_close (kw) + +pointer kw # io: pointer to keyword list struct + +begin + if (kw != NULL) { + call mfree (KW_NAME_PTR (kw), TY_CHAR) + call mfree (KW_TYPE_PTR (kw), TY_INT) + call mfree (KW_MATCH_PTR (kw), TY_INT) + call mfree (kw, TY_POINTER) + kw = NULL + } +end + +# expand template for current keyword +# This can be called repeatedly after tkw_open. Each time it is called, +# the previous list will be overwritten. + +procedure tkw_find (tp, kw, keyword) + +pointer tp # i: pointer to table struct +pointer kw # i: pointer to keyword list struct +char keyword[ARB] # i: keyword name template +#-- +pointer sp +pointer template # keyword converted to upper case, etc +char pat[SZ_FNAME] # encoded pattern +int lenpat +int k # counter for keywords that match template +int i, nmatch +int strlen() +int patmake(), pat_amatch() +errchk uc_template, patmake, pat_amatch + +begin + call smark (sp) + call salloc (template, SZ_FNAME, TY_CHAR) + + # Convert the keyword to upper case (except for special keywords). + call uc_template (keyword, Memc[template], SZ_FNAME) + + lenpat = patmake (Memc[template], pat, SZ_FNAME) + + k = 0 + do i = 1, NUM_KEYWORDS(kw) { + + if (strlen (KW_NAME(kw,i)) < 1) # ignore blank keywords + next + + nmatch = pat_amatch (KW_NAME(kw,i), 1, pat) + if (nmatch == strlen (KW_NAME(kw,i))) { + k = k + 1 + KW_MATCH(kw,k) = i + } + } + NUM_MATCH(kw) = k + + call sfree (sp) +end + +# get all current keywords and expand template again + +procedure tkw_reopen (tp, kw, keyword) + +pointer tp # i: pointer to table struct +pointer kw # io: pointer to keyword list struct +char keyword[ARB] # i: keyword name template +#-- +pointer tkw_open() + +begin + call tkw_close (kw) + kw = tkw_open (tp) + call tkw_find (tp, kw, keyword) +end + +# This routine converts the keyword template to upper case (except for +# special keywords) and replaces "*" with "?*" for use with patmake. + +procedure uc_template (keyword, template, maxch) + +char keyword[ARB] # i: keyword template +char template[ARB] # o: template converted to upper case +int maxch # i: max length of template string +#-- +char ch +int ip, op +int strncmp() +bool streq() + +begin + # Make "$I" equivalent to i_table. + if (streq (keyword, "$I")) { + call strcpy ("i_table", template, maxch) + return + } + + # Copy special keywords to output without change. + if (strncmp (keyword, "i_", 2) == 0) { + call strcpy (keyword, template, maxch) + return + } + + ip = 1 + op = 1 + ch = keyword[ip] + + while (ch != EOS) { + + # Map "*" into "?*". + if (ch == '*' && ip > 1) { + template[op] = '?' + op = op + 1 + } + + if (op > maxch) + call error (1, "keyword template string is too long") + + if (IS_LOWER(ch)) + template[op] = TO_UPPER(ch) + else + template[op] = ch + + op = op + 1 + ip = ip + 1 + ch = keyword[ip] + } + template[op] = EOS +end + +# This function returns the number of keywords that matched the template, +# i.e. after calling tkw_find. + +int procedure tkw_len (kw) + +pointer kw # i: pointer to keyword list struct + +begin + return (NUM_MATCH(kw)) +end + +# This routine can be used to loop through the list of matched keywords, +# returning the keyword number and name. k is the index in the list of +# keywords that match the template, and keynum is the index of the keyword +# in the header. k runs from 1 to tkw_len. keynum can be passed to +# tbhgnp to get a keyword or to tbhdel to delete a keyword. + +procedure tkw_getkw (kw, k, keynum, keyword, maxch) + +pointer kw # i: pointer to keyword list struct +int k # i: index of keyword in list of match keywords +int keynum # o: keyword number in header +char keyword[ARB] # o: keyword name +int maxch # i: max length of keyword string +#-- +int knum + +begin + if (k < 1 || k > NUM_MATCH(kw)) + call error (1, "tkw_getkw: index is out of range") + + knum = KW_MATCH(kw,k) + keynum = knum - NUM_SPECIAL + + call strcpy (KW_NAME(kw,knum), keyword, maxch) +end + +# This routine returns the value of one of the special keywords. + +procedure tkw_special (tp, keyword, value, maxch) + +pointer tp # i: pointer to table struct +char keyword[ARB] # i: current keyword +char value[ARB] # o: value of keyword +int maxch # i: size of value string +#-- +pointer sp +pointer tablename # name of table +pointer filename # name of table without brackets +pointer hduname # returned by tbparse and ignored +int hdu # ignored +int junk, tbparse() +long ostruct[LEN_FINFO] # contains info about file +long ctime # creation or modification time +char datestr[SZ_TIME] # ctime converted to a string +int finfo() +int tbltype, tbl_subtype +int tbpsta() +bool streq() + +begin + call smark (sp) + + if (streq (keyword, "$I") || streq (keyword, "i_table")) { + + # The table name. + call tbtnam (tp, value, maxch) + + } else if (streq (keyword, "i_file")) { + + # The name of the file containing the table. + call salloc (tablename, SZ_FNAME, TY_CHAR) + call salloc (filename, SZ_FNAME, TY_CHAR) + call salloc (hduname, SZ_FNAME, TY_CHAR) + + call tbtnam (tp, Memc[tablename], SZ_FNAME) + junk = tbparse (Memc[tablename], Memc[filename], + Memc[hduname], SZ_FNAME, hdu) + call strcpy (Memc[filename], value, maxch) + + } else if (streq (keyword, "i_ctime")) { + + # The time the file was created (or last modified). + call salloc (tablename, SZ_FNAME, TY_CHAR) + call salloc (filename, SZ_FNAME, TY_CHAR) + call salloc (hduname, SZ_FNAME, TY_CHAR) + + # Get file name. + call tbtnam (tp, Memc[tablename], SZ_FNAME) + junk = tbparse (Memc[tablename], Memc[filename], + Memc[hduname], SZ_FNAME, hdu) + + if (finfo (Memc[filename], ostruct) == ERR) + call error (1, "Can't get info about file") + + ctime = FI_CTIME(ostruct) + call cnvtime (ctime, datestr, SZ_TIME) + call strcpy (datestr, value, maxch) + + } else if (streq (keyword, "i_nrows")) { + + # The number of rows in the table. + call sprintf (value, maxch, "%d") + call pargi (tbpsta (tp, TBL_NROWS)) + + } else if (streq (keyword, "i_ncols")) { + + # The number of columns in the table. + call sprintf (value, maxch, "%d") + call pargi (tbpsta (tp, TBL_NCOLS)) + + } else if (streq (keyword, "i_npar")) { + + # The number of header keywords in the table. + call sprintf (value, maxch, "%d") + call pargi (tbpsta (tp, TBL_NPAR)) + + } else if (streq (keyword, "i_type")) { + + # The type of the table. + tbltype = tbpsta (tp, TBL_WHTYPE) + tbl_subtype = tbpsta (tp, TBL_SUBTYPE) + + if (tbltype == TBL_TYPE_TEXT) { + + if (tbl_subtype == TBL_SUBTYPE_SIMPLE) + call strcpy ("text", value, maxch) + else if (tbl_subtype == TBL_SUBTYPE_EXPLICIT) + call strcpy ("text with explicit column definitions", + value, maxch) + else + call strcpy ("text", value, maxch) + + } else if (tbltype == TBL_TYPE_FITS) { + + if (tbl_subtype == TBL_SUBTYPE_ASCII) + call strcpy ("fits ascii", value, maxch) + else if (tbl_subtype == TBL_SUBTYPE_BINTABLE) + call strcpy ("fits binary", value, maxch) + else if (tbl_subtype == TBL_SUBTYPE_IMAGE) + call strcpy ("fits primary header", value, maxch) + else + call strcpy ("fits", value, maxch) + + } else if (tbltype == TBL_TYPE_S_ROW) { + + call strcpy ("stsdas row ordered", value, maxch) + + } else if (tbltype == TBL_TYPE_S_COL) { + + call strcpy ("stsdas column ordered", value, maxch) + + } else { + call strcpy ("unknown", value, maxch) + } + + } else { + + call sfree (sp) + call error (1, "not a special keyword") + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/thistogram.par b/pkg/utilities/nttools/thistogram.par new file mode 100644 index 00000000..ce34cd34 --- /dev/null +++ b/pkg/utilities/nttools/thistogram.par @@ -0,0 +1,14 @@ +intable,s,a,"",,,"input tables" +outtable,s,a,"STDOUT",,,"output tables or STDOUT" +column,s,a,"",,,"column in input tables" +nbins,i,h,100,1,,"total number of bins" +lowval,r,h,INDEF,,,"lower limit for histogram" +highval,r,h,INDEF,,,"upper limit for histogram" +dx,r,h,INDEF,,,"bin width" +clow,r,h,INDEF,,,"center of first bin" +chigh,r,h,INDEF,,,"center of last bin" +rows,s,h,"-",,,"range of rows to use for histogram" +outcolx,s,h,"value",,,"column name for bin centers" +outcoly,s,h,"counts",,,"column name for histogram values" +Version,s,h,"18March1994",,,"date of installation" +mode,s,h,"al" diff --git a/pkg/utilities/nttools/threed/doc/selectors.hlp b/pkg/utilities/nttools/threed/doc/selectors.hlp new file mode 100644 index 00000000..fd5390a7 --- /dev/null +++ b/pkg/utilities/nttools/threed/doc/selectors.hlp @@ -0,0 +1,91 @@ +.help selectors Nov96 tables +.ih +NAME +selectors -- Table row/column selector syntax. +.ih +BASIC SYNTAX +Selectors are appended to table names using a bracket notation. The +construct "[c:......]" appended to a table name tells that a column +selector exists. In a similar way, the construct "[r:......]" indicates +a row selector. +.ih +COLUMN SELECTOR +The basic structure of a column selector is a list of column patterns +separated by commas. The column pattern is either a column name, a file +name containing a list of column names, or a pattern using the usual IRAF +pattern matching syntax. For example, the string +.nf + [c:a[1-9], b, time*, @column.lis] +.fi + +would be expanded as the column names a1 through a9, b, any column +name beginning with "time", and all the column names in the file +column.lis. If the column list is entirely whitespace, all columns are +selected. If the first non-white character is the negation character (~), +the selected columns will include all columns not matched by the list. +The negation character only has this meaning at the beginning of the list. +.ih +ROW SELECTOR +Rows are selected according to a qpoe filter. The filter is evaluated +at each table row, and the row is selected if the filter is true. + +For sake of an example, suppose we have a star catalog with the +columns Name, Ra, Dec, V, B-V, and U-B. The simplest sort of filter is +the equality test. The name of the column appears on the left of an +equals sign and the column value appears on the right. For example, +[name=eta_uma]. (The brackets in this and the following example are +not actually part of the filter.) Column numbers can be used in place +of the column name. This is especially useful for ascii +tables. Values can be either numbers or strings. It is usually not +necessary to place strings in quotes. However, any string (including +a column name) contains embedded blanks or characters significant to +the qpoe filter, such a equal signs, commas, or colons, it should be +placed in quotes. + +Ranges of values can be specified by giving the endpoints of the +ranges separated by a colon. For example, [r:v=10:15] selects all rows +with visual magnitude between 10 and 15. Ranges include their +endpoints. Ranges can also be used with strings as well as +numbers. Ranges can also be one sided. The filter [r:dec=80:] selects +all rows with declination greater than or equal to eighty degress and +the filter [r:dec=:-40] selects all declinations less than or equal to +forty degrees south. A filter can contain a list of single values and +ranges. The values in the list should be enclosed in parentheses. For +example, [r:name=(eta_uma,alpha_lyr)] or [r:b-v=(-1:0,0.5:1)]. + +Individual values or ranges can be negated by placing a ! in front of +them. For example, [r:name=!eta_uma] selects every row except the star +named eta_uma and [r:ra=!0:6] selects all rows except those with right +ascension between zero and six hours. An entire list can be negated by +placing a ! in front of the column name or the parentheses enclosing +the list. The filters [r:!name=(eta_uma,alpha_lyr)] and +[r:name=!(eta_uma,alpha_lyr)] and [r:name=(!eta_uma,!alpha_lyr)] are all +equivalent. + +Filters can test more than one column in a table. The individual tests +are separated by commas or semicolons. All tests in the filter must +succeed for the filter to be accepted. For example, +[r:ra=1.3:1.4,dec=40:42] selects a rectangular region in the catalog. A +range of row numbers can also be selected by placing the word row on +the left side of the equals sign. For example, [r:row=10:20] selects +rows from ten to twenty inclusive and [r:row=50:] selects all rows from +fifty on. Row selection can be combined with any other test in a +filter. A filter, can also be placed in an include file, for example +[r:@filter.lis]. Include files can be a part of a larger expression +and include files can contain other files, up to seven levels deep. +.ih +EXAMPLES +.nf +1. "[c:WAVELENGTH,FLUX]" selects columns named "WAVELENGTH" and + "FLUX" + +2. "[r:WAVELENGTH=(4000:5000)]" selects all rows in which the WAVELENGTH + column assumes values in between 4000 and + 5000. + +3. "[c:FLUX][r:row=(25:30)]" selects column FLUX and all rows from 25 + to 30. +.fi +.ih +SEE ALSO +.endhelp diff --git a/pkg/utilities/nttools/threed/doc/tiimage.hlp b/pkg/utilities/nttools/threed/doc/tiimage.hlp new file mode 100644 index 00000000..1319d2e0 --- /dev/null +++ b/pkg/utilities/nttools/threed/doc/tiimage.hlp @@ -0,0 +1,108 @@ +.help tiimage Jan97 tables +.ih +NAME +tiimage -- Inserts images into rows of a 3-D table. +.ih +USAGE +tiimage input outtable +.ih +DESCRIPTION +This task performs the inverse operation of task tximage: it inserts one or +more images into rows of a 3-D table The input may be a filename template, +including wildcard characters, or the name of a file (preceded by an @ sign) +containing image names. The output is a single 3-D table name. +Each image in the input list is inserted as an array into a single cell at +the specified row in the output table. Any dimensionality information existent +in the input image is lost in the process, that is, the image will be always +inserted as a 1-D array, regardless of its number of axis. + +If the output table exists, insertion will be done in place. Alternatively, +the task can create a 3-D table from information taken either from a template +3-D table, or, if this table is not supplied, from the input images themselves. +This task supports a column selector in table names. This selector may be +used to select a single column in the table. If no selector is used, all +columns will be processed. Type 'help selectors' to see a description of +the selector syntax. + +If the output table exists, insertion may take place in two ways. If the +output table name contains a column selector that selects a single column +in the table, all input images will be inserted in that column, starting +at the row pointed by task parameter "row". +If "row" is negative or INDEF the task will look for the ORIG_ROW +keyword in the image header and use that keyword value for row number. +The second mode of insertion in an existing table is used if no matching +column selector is found in the output table name. In this case the task +will look for the columnar information written in the input image header by +task tximage, and use that information to place the image in the proper +column. If no columnar information exists in the header, or if the column +name in there does not match any column in the output table, the image is +skipped and the user warned. The "row" parameter processing works the same +way in this second mode. + +If the output table does not exist, the task will look for a template table +where to take column information from. If the template exists, the insertion +operation will be performed in an analogous way as above. Notice that the +result may be a single-column table if the template has a valid (matching) +column selector in its name, or a sparse table if not, because only the +actual input images will be stored in an otherwise empty table (the template +data is not copied into the output, only the column descriptors). + +If the template is missing, the task will attempt to retrieve columnar +information from the input image headers and build the output table with +enough columns and rows to fit all images in the list. Only images that +have columnar information in their headers can be processed, though. If +no images are found with the proper header keywords, no output takes place. + +NOTE: Both the output and template table names must always be supplied +complete, including their extension. Otherwise the task may get confused +on the existence of an already existing table. + +The column matching criterion is based on the column name. An error results +when data types in input image and output column do not agree. + +If the maximum array size in a target column in the output 3-D table is +larger than the number of pixels in the input image, the array will be filled +up starting from its first element, and the empty elements at the end will +be set to INDEF. If the maximum array size is smaller than the number of +pixels, insertion begins by the first pixel up to the maximum allowable size, +the remaining pixels being ignored. +.ih +PARAMETERS +.ls input [image name list/template] +A list of one or more images to be inserted. +.le +.ls outtable [table name] +Name of 3-D output table, including extension. No support exists for +"STDOUT" (ASCII output). +.le +.ls (template = "") [table name] +Name of 3-D table to be used as template when creating a new output table. +.le +.ls (row = INDEF) [int] +Row where insertion begins. If set to INDEF or a negative value, the row +number will be looked for in the input image header. +.le +.ls (verbose = yes) [boolean] +Display names as files are processed ? +.le +.ih +EXAMPLES +Insert images into a 3-D table at column named FLUX: + +.nf +cl> tiimage flux*.hhh "otable.tab[c:FLUX]" +.fi +.ih +BUGS +The output and template table names must be supplied in full, including +the extension (e.g. ".tab"). If the output table name is not typed in full, +the task will create a new table in place of the existing one, with only +the rows actually inserted. This behavior relates to the way the underlying +"access" routine in IRAF's fio library works. +.ih +REFERENCES +This task was written by I. Busko. +.ih +SEE ALSO +tximage, selectors +.endhelp diff --git a/pkg/utilities/nttools/threed/doc/titable.hlp b/pkg/utilities/nttools/threed/doc/titable.hlp new file mode 100644 index 00000000..f0479b6b --- /dev/null +++ b/pkg/utilities/nttools/threed/doc/titable.hlp @@ -0,0 +1,100 @@ +.help titable Mar97 tables +.ih +NAME +titable -- Inserts 2-D tables into rows of a 3-D table. +.ih +USAGE +titable intable outtable +.ih +DESCRIPTION +This task performs the inverse operation of task txtable: it inserts one or +more 2-D tables into rows of a 3-D table The input may be a filename +template, including wildcard characters, or the name of a file (preceded by +an @ sign) containing table names. The output is a single 3-D table name. +If the output table exists, insertion will be done in place. If the output +table does not exist, it will be created. The input and output tables must +not be the same. + +This task supports row/column selectors in the input table names. These +may be used to select subsets of both rows and columns from the input table. +If no selectors are used, all columns and rows will be processed, +Type 'help selectors' to see a description of the selector syntax. + +When creating a new output table, the information describing its columns +can be taken from two sources. If parameter 'template' has the name of an +existing 3-D table, the column descriptions, including maximum array sizes, +will be taken from that table. If 'template' has an invalid or null ("") +value, the column-defining information will be take from the first table +in the input list, where its number of rows will define the maximum array +size allowed in the table being created. Column selectors are allowed in +the template table. + +NOTE: Both the output and template table names must always be supplied +complete, including their extension. Otherwise the task may get confused +on the existence of an already existing table. + +Insertion is performed by first verifying if column names in both input +and output tables match. If a match is found, values taken from that column +and all selected rows from the input table will be stored as a 1-dimensional +array in a single cell in the corresponding column in the output 3-D table. +The row in this table where the insertion takes place is selected by the +"row" task parameter. It points to the row where the first table in the input +list will be inserted, subsequent tables in the list will be inserted into +subsequent rows. This mechanism is superseded if the "row" parameter is set +to INDEF or a negative value, and the keyword "ORIG_ROW" is found in the +header of the input table. This keyword is created by task txtable and its +value supersedes the row counter in the task. + +If the maximum array size in a target column in the output 3-D table is +larger than the number of selected input rows, the array will be filled +up starting from its first element, and the empty elements at the end will +be set to INDEF (or "" if it is a character string column). If the maximum +array size is smaller than the number of selected rows, insertion begins by +the first selected row up to the maximum allowable size, the remaining rows +being ignored. + +This task correctly handles scalars stored in the input table header +by task txtable. Since the selector mechanism does not work with these +scalars, the task will always insert them into the output table, provided +there is a match in column names. +.ih +PARAMETERS +.ls intable [file name list/template] +A list of one or more tables to be inserted. Row/column selectors are supported. +.le +.ls outtable [table name] +Name of 3-D output table, including extension. No support exists for +"STDOUT" (ASCII output). +.le +.ls (template = "") [table name] +Name of 3-D table to be used as template when creating a new output table. +.le +.ls (row = INDEF) [int] +Row where insertion begins. If set to INDEF or a negative value, the row +number will be looked for in the input table header. +.le +.ls (verbose = yes) [boolean] +Display names of input and output tables as files are processed ? +.le +.ih +EXAMPLES +Insert columns named FLUX and WAVELENGTH from input tables into a 3-D table: + +.nf +cl> titable "itable*.tab[c:FLUX,WAVELENGTH]" otable.tab +.fi + +.ih +BUGS +The output and template table names must be supplied in full, including +the extension (e.g. ".tab"). If the output table name is not typed in full, +the task will create a new table in place of the existing one, with only the +rows actually inserted. This behavior relates to the way the underlying +"access" routine in IRAF's fio library works. +.ih +REFERENCES +This task was written by I. Busko. +.ih +SEE ALSO +txtable, selectors +.endhelp diff --git a/pkg/utilities/nttools/threed/doc/tscopy.hlp b/pkg/utilities/nttools/threed/doc/tscopy.hlp new file mode 100644 index 00000000..144b483a --- /dev/null +++ b/pkg/utilities/nttools/threed/doc/tscopy.hlp @@ -0,0 +1,94 @@ +.help tscopy Nov96 tables +.ih +NAME +tscopy -- Copy tables. +.ih +USAGE +tscopy intable outtable +.ih +DESCRIPTION +This task is used to copy tables. The input may be a filename +template, including wildcard characters or the name of a file (preceded +by an @ sign) containing table names. The output may be either a directory +specification or a list of table names. If the output is a list of tables +then there must be the same number of names in the input and output lists, +and the names are taken in pairs, one from input and one from output. +The input and output tables must not be the same. + +This task supports row/column selectors in the input table name. These +may be used to select subsets of both rows and columns from the input table. +Type 'help selectors' to see a description of the selector syntax. + +NOTE: Be careful when using a wildcard for the extension. +If you have the files 'table.tab' and 'table.lis' in the current directory, +for example, then the command "tscopy tab* test/" would copy both files to the subdirectory +'test'. +.ih +PARAMETERS +.ls intable [file name template] +A list of one or more tables to be copied. Row/column selectors are supported. +.le +.ls outtable [file name template] +Either a directory name or a list of output table names. The standard +value "STDOUT" generates ASCII output that can be redirected to a file. +.le +.ls (verbose = yes) [boolean] +Display names of input and output tables as files are copied? +.le +.ih +EXAMPLES +1. To simply copy a table: + +.nf + cl> tscopy table tablecopy +.fi + +2. To copy a table into an ASCII table: + +.nf + cl> tscopy table STDOUT > table.txt +.fi + +3. To copy several tables: + +.nf + cl> tscopy table1,table2,tab67 a,b,c + cl> tscopy tab*.tab a,b,c +.fi +In the latter case the extension is given explicitly in case there +are other files beginning with "tab" that are not tables; there must +be exactly three tables beginning with "tab" because the output list +has three names. + +4. To copy a set of tables to a new directory: + +.nf + cl> tscopy table*.tab directory + or + cl> tscopy table*.tab directory$ + or + cl> tscopy table*.tab osdirectory +.fi + +where "directory" is an IRAF environment variable for a directory name, +and "osdirectory" is an operating system directory name +(e.g., "/user/me/" in UNIX). + +5. To copy a subset of rows and columns: + +.nf + cl> tscopy "table.tab[c:wave,flux][r:wave=(4000:5000)]" tableout +.fi + +This command will copy only columns named "wave" and "flux" from the input +table to the output. It will also select and copy only the rows in which +the "wave" value lies between 4000 and 5000. +.ih +BUGS +.ih +REFERENCES +This task was written by Bernie Simon. +.ih +SEE ALSO +selectors +.endhelp diff --git a/pkg/utilities/nttools/threed/doc/tximage.hlp b/pkg/utilities/nttools/threed/doc/tximage.hlp new file mode 100644 index 00000000..9f331958 --- /dev/null +++ b/pkg/utilities/nttools/threed/doc/tximage.hlp @@ -0,0 +1,85 @@ +.help tximage Jan97 tables +.ih +NAME +tximage -- Extract 1-D images from cells of a 3-D table. +.ih +USAGE +tximage intable output +.ih +DESCRIPTION +This task extracts one or more 1-D images from cells of a 3-D table. +The input may be a filename template, including wildcard characters, +or the name of a file (preceded by an @ sign) containing table names. +The output may be either a directory specification or a list of image names. +If the output is a list of images then there must be the same number of names +in the input and output lists, and the names are taken in pairs, one from +input and one from output. + +Images can be extracted only from a single column in the input table. +That column must be designated by an appropriate column selector appended to +the table name. Type 'help selectors' to get more information on row/column +selector syntax. + +Row selectors may be used to select subsets of rows from the input table. +If no row selector is used, all rows will be extracted, and the number +of output images will be the number of rows in the input table. + +Since one input table may generate several output images, the task adopts +the following naming scheme for these output images: their names are +built by appending a suffix to the name given in parameter "output". +The suffix has the form "_rXXXX", where XXXX stands for the row number +in the input table. The suffix is appended before the file name extension. +The task recognizes as valid image name extensions the values ".??h", +".fits" and ".fit". Any other extension is assumed to be part of the root +file name. If only one row is extracted, no suffixing takes place. + +NOTE: Be careful when using a wildcard for the extension. +If you have the files "table.tab" and "table.lis" in the current directory, +for example, then the command "tximage tab* test/" would expand both files +to the subdirectory "test". + +Basic column information describing the column where the image came from +is written into the image header in the "COLDATA" keyword. This information +can be used later by task 'tiimage' to re-insert the image into a cell of +a 3-D table. + +The task does not propagate array dimensionality when extracting arrays +into images. If dimensionality information exists in the 3-D table, that +information is lost, that is, the table cell from the input table is written +as a structureless, plain 1-D image. + +The input row number is written to the header of the output image in +keyword ORIG_ROW. This allows 'tiimage' to put the data back where +'tximage' got them from. +.ih +PARAMETERS +.ls intable [file name list/template] +A list of one or more tables to be expanded. A column selector selecting +a single column is mandatory. Row selectors are supported as well. +.le +.ls output [file name template] +Either a directory name or a list of output image names. +.le +.ls (verbose = yes) [boolean] +Display names of input and output files ? +.le +.ih +EXAMPLES +Extract 1-D images from a column named FLUX from rows 11 to 13 of a 3-D +table: + +.nf +cl> tximage "table.tab[c:FLUX][r:row=(11:13)]" image +.fi + +This will generate three images named "image_r0011", "image_r0012" +and "image_r0013". +.ih +BUGS +.ih +REFERENCES +This task was written by I. Busko. +.ih +SEE ALSO +tiimage, selectors +.endhelp diff --git a/pkg/utilities/nttools/threed/doc/txtable.hlp b/pkg/utilities/nttools/threed/doc/txtable.hlp new file mode 100644 index 00000000..462b8b95 --- /dev/null +++ b/pkg/utilities/nttools/threed/doc/txtable.hlp @@ -0,0 +1,89 @@ +.help txtable Jan97 tables +.ih +NAME +txtable -- Extract rows from a 3-D table into separate 2-D tables. +.ih +USAGE +txtable intable outtable +.ih +DESCRIPTION +This task extracts one or more rows from a 3-D table and writes each row +as a 2-D table. The input may be a filename template, including +wildcard characters, or the name of a file (preceded by an @ sign) containing +table names. The output may be either a directory specification or a list +of table names. If the output is a list of tables then there must be the same +number of names in the input and output lists, and the names are taken in +pairs, one from input and one from output. The input and output tables must +not be the same. + +This task supports row/column selectors in the input table name. These +may be used to select subsets of both rows and columns from the input table. +If no selectors are used, all columns will be extracted, and the number +of output tables will be the number of rows in the input table. +Type 'help selectors' to see a description of the selector syntax. + +Since one input table may generate several output tables, the task adopts +the following naming scheme for these output tables: their names are +built by appending a suffix to the name given in parameter "outtable". +The suffix has the form "_rXXXX", where XXXX stands for the row number +in the input table. The suffix is appended before the file name extension. +The task recognizes as valid table name extensions the values ".tab", +".fits" and ".fit". Any other extension is assumed to be part of the root +file name. If only one row is extracted, or in case of ASCII output, no +suffixing takes place. + +NOTE: Be careful when using a wildcard for the extension. +If you have the files "table.tab" and "table.lis" in the current directory, +for example, then the command "txtable tab* test/" would expand both files +to the subdirectory "test". + +There are two forms of handling scalar columns in the input table. If +task parameter "compact" is set to 'no', the corresponding column in the +output table will have the scalar value in its first row, and all other +rows will be filled with INDEF. If parameter "compact" is set to 'yes', +scalar columns will be written into the header as a set of header keywords. +These keywords can be used later by task 'titable' to re-insert the +scalars as cell elements of a 3-D table. + +The task does not propagate array dimensionality when extracting arrays +into columns in the output table. If dimensionality information exists +in the 3-D table, that information is lost, that is, the table cell from +the input table is written as a structureless, plain table column. + +The input row number is written to the header of the output table in +keyword ORIG_ROW. This allows 'titable' to put the data back where +'txtable' got them from. +.ih +PARAMETERS +.ls intable [file name list/template] +A list of one or more tables to be expanded. Row/column selectors are supported. +.le +.ls outtable [file name template] +Either a directory name or a list of output table names. The standard +value "STDOUT" generates ASCII output that can be redirected to a file. +.le +.ls (compact = yes) [boolean] +Write scalars as header keywords ? +.le +.ls (verbose = yes) [boolean] +Display names of input and output tables as files are processed ? +.le +.ih +EXAMPLES +Extract columns named FLUX and WAVELENGTH from rows 11 to 13 of a 3-D table: + +.nf +cl> txtable "table.tab[c:FLUX,WAVELENGTH][r:row=(11:13)]" tableout +.fi + +This will generate three tables named "tableout_r0011", "tableout_r0012" +and "tableout_r0013". +.ih +BUGS +.ih +REFERENCES +This task was written by I. Busko. +.ih +SEE ALSO +titable, selectors +.endhelp diff --git a/pkg/utilities/nttools/threed/mkpkg b/pkg/utilities/nttools/threed/mkpkg new file mode 100644 index 00000000..ee093810 --- /dev/null +++ b/pkg/utilities/nttools/threed/mkpkg @@ -0,0 +1,25 @@ +# Make the threed package +# I.Busko, 21-Nov-1996 +# +# Special keywords recognized by IRAF mkpkg files: +# +# mkpkg relink update object library and link +# mkpkg linkonly skip object library updates and just link +# mkpkg install move executable to lib$ +# mkpkg update update object library, link, and move to lib$ + + +$call libpkg.a +$exit + +libpkg.a: + $call generic@tiimage + $call generic@titable + $call generic@txtable + + @tscopy + @txtable + @tximage + @titable + @tiimage + ; diff --git a/pkg/utilities/nttools/threed/tblerr.h b/pkg/utilities/nttools/threed/tblerr.h new file mode 100644 index 00000000..cbf6ac36 --- /dev/null +++ b/pkg/utilities/nttools/threed/tblerr.h @@ -0,0 +1,27 @@ +# tblerr.h -- error codes for table I/O routines +# +# Phil Hodge, 30-Sep-87 Change numbers and reorganize. +# Phil Hodge, 2-Jun-89 Remove 4867 from error numbers. + +define ER_TBNAMTOOLONG 01 # file name (incl extension) is too long +define ER_TBBADMODE 02 # I/O mode is not supported for a table +define ER_TBREADONLY 03 # attempt to modify a readonly table + +define ER_TBTOOLATE 31 # too late, table is already open +define ER_TBNOTOPEN 32 # table must be open for this option +define ER_TBBADOPTION 33 # invalid option for tbpset +define ER_TBUNKPARAM 34 # unknown parameter for tbpsta + +define ER_TBCOLEXISTS 41 # column already exists +define ER_TBBADTYPE 42 # invalid data type for a table column + +define ER_TBBEYONDEOF 51 # requested row is beyond EOF + +define ER_TBPARNOTFND 61 # header parameter not found +define ER_TBMUSTADD 62 # new parameter must be added, not put +define ER_TBDTYPECONFLICT 63 # can't put numeric parameter as comment + +define ER_TBCORRUPTED 81 # table or memory is corrupted +define ER_TBCOLBADTYP 82 # bad data type (memory corrupted?) +define ER_TBFILEMPTY 83 # table data file is empty +define ER_TBCINFMISSING 84 # EOF while reading column info diff --git a/pkg/utilities/nttools/threed/tbtables.h b/pkg/utilities/nttools/threed/tbtables.h new file mode 100644 index 00000000..60e79159 --- /dev/null +++ b/pkg/utilities/nttools/threed/tbtables.h @@ -0,0 +1,123 @@ +# tbtables.h -- Internal definitions for the table I/O package. + +# Software version number. +# Version 0 corresponds to STSDAS and TABLES versions 1.2.3 and earlier. +# The row length was restricted to integral multiples of the size of a +# real number. +# Version 1 begins with STSDAS and TABLES version 1.3. Short integer +# datatype was introduced, and character strings were rounded up to a +# multiple of the number of bytes in a char. The row length is allowed +# to be any integral multiple of SZ_CHAR. +# Version 2 allows header parameters to have comments. +# This change was made after TABLES version 1.3.3 was released. +define TBL_CURRENT_VERSION 2 + +# Default maximum number of user parameters. The current value is TB_MAXPAR. +define DEFMAXPAR 5 + +# Default maximum number of columns. The current value is TB_MAXCOLS. +define DEFMAXCOLS 5 + +# This section describes the size information record. +define LEN_SIZINFO 12 # unit = SZ_INT32 +define SZ_SIZINFO (LEN_SIZINFO * SZ_INT32) +define S_NPAR $1[1] # Number of user parameters +define S_MAXPAR $1[2] # Max number of user parameters +define S_NROWS $1[3] # Number of rows +define S_ALLROWS $1[4] # Number of rows allocated +define S_NCOLS $1[5] # Number of columns defined +define S_MAXCOLS $1[6] # Current max number of columns +define S_COLUSED $1[7] # Chars used by defined columns +define S_ROWLEN $1[8] # Total row length alloc (chars) +define S_TYPE $1[9] # Type (row or column ordered) +define S_VERSION $1[10] # Software version number + +# This is the size of the table-descriptor structure. +define LEN_TBLSTRUCT (28) + +# General descriptive information. (R) means relevant only for row-ordered +# tables, while (C) means relevant only for column-ordered tables. +define TB_TYPE Memi[$1] # what type of table +define TB_NPAR Memi[$1+1] # number of user paramters +define TB_MAXPAR Memi[$1+2] # max number of user paramters +define TB_NROWS Memi[$1+3] # number of rows +define TB_ALLROWS Memi[$1+4] # (C) allocated number of rows +define TB_NCOLS Memi[$1+5] # number of columns +define TB_MAXCOLS Memi[$1+6] # current max number of columns +define TB_COLUSED Memi[$1+7] # (R) chars used by columns +define TB_ROWLEN Memi[$1+8] # (R) row length = chars alloc +define TB_VERSION Memi[$1+9] # Software version number +define TB_BOD Meml[$1+10] # L beg of data (in SZ_CHAR) +define TB_IOMODE Memi[$1+11] # I/O mode + +# Flags +define TB_IS_OPEN Memb[$1+12] # Table is open? +define TB_READONLY Memb[$1+13] # Readonly? +define TB_MODIFIED Memb[$1+14] # Actually been changed? + +# File descriptor for the table file +define TB_FILE Memi[$1+15] + +# Pointers. TB_INDEF is only used for row-ordered tables. +define TB_INDEF Memi[$1+16] # Pointer to indef record buffer +define TB_COLPTR Memi[$1+17] # Ptr to array of column ptrs + +# These are for tables in CDF files or FITS files. +define TB_F_TYPE Memi[$1+18] # CDF, FITS, or ordinary file +define TB_HDU Memi[$1+19] # number of HDU in FITS file +define TB_EXTVER Memi[$1+20] # version number +define TB_OVERWRITE Memi[$1+21] # +1 --> yes, 0 --> no +define TB_HDUTYPE Memi[$1+22] # 1--> ascii; 2 --> binary +define TB_CD Memi[$1+23] # returned by cd_open() +define TB_EXTNAME_PTR Memi[$1+24] # pointer to CDF name or EXTNAME +define TB_EXTNAME Memc[TB_EXTNAME_PTR($1)] + +# These two are for text tables. +define TB_COMMENT Memi[$1+25] # pointer to comment string +define TB_SZ_COMMENT Memi[$1+26] # size of comment string + +# Table name +define TB_NAME_PTR Memi[$1+27] # pointer to table name string +define TB_NAME Memc[TB_NAME_PTR($1)] + + +# Array of pointers to column information. This array can be reallocated +# to allow more columns; the current size at any time is TB_MAXCOLS. +define TB_COLINFO Memi[TB_COLPTR($1)+$2-1] + + + +# Column information structure. +define LEN_COLSTRUCT 16 # unit = SZ_STRUCT +define SZ_COLSTRUCT (LEN_COLSTRUCT * SZ_STRUCT) + +define COL_NUMBER Memi[$1] # Column number +define COL_OFFSET Memi[$1+1] # Offset from start of row +define COL_LEN Memi[$1+2] # Chars for data element +define COL_DTYPE Memi[$1+3] # Data type +define COL_NAME Memc[P2C($1+4)] # Column name 19 +define COL_UNITS Memc[P2C($1+9)] # Units 19 +define COL_FMT Memc[P2C($1+14)] # Print format 7 +# Next available field is ($1 + 16). + + +# Definitions of data types. These agree with iraf.h. +define TBL_TY_BOOL 1 +define TBL_TY_CHAR 2 +define TBL_TY_SHORT 3 +define TBL_TY_INT 4 +define TBL_TY_REAL 6 +define TBL_TY_DOUBLE 7 + +# Undefined double for tables. This agrees with the pre-IRAF 2.11 INDEFD. +define TBL_INDEFD 1.6d38 +define TBL_IS_INDEFD (($1)==TBL_INDEFD) + +# These two (which are in tbset.h) are used for the file type TB_F_TYPE +# as well as table type TB_TYPE. +# (moved) define TBL_TYPE_FITS 14 # FITS table +# (moved) define TBL_TYPE_CDF 15 # common datafile format +# These two are modifiers for the table type in case it's a FITS table. +# They are the value of TB_HDUTYPE. +define TBL_FITS_ASCII 1 # FITS ASCII table +define TBL_FITS_BINARY 2 # FITS BINTABLE diff --git a/pkg/utilities/nttools/threed/tiimage.par b/pkg/utilities/nttools/threed/tiimage.par new file mode 100644 index 00000000..27b9c861 --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage.par @@ -0,0 +1,7 @@ +input,s,a,"",,,">Input images" +outtable,s,a,"",,,">Output table" +template,s,h,"",,,">Template table" +row,i,h,INDEF,,,">Begin insertion in row" +verbose,b,h,yes,,,">Print operations performed ?" +version,s,h,"30Jan97",,, +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/threed/tiimage/design1.txt b/pkg/utilities/nttools/threed/tiimage/design1.txt new file mode 100644 index 00000000..8726f475 --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/design1.txt @@ -0,0 +1,353 @@ + + + Design of 3-D table translator for image insertion + -------------------------------------------------- + + + Author: I. Busko + + + Revision history: + 01/16/97 - First version. + + + +1. Specifications / requirements: + +This task will perform the inverse operation performed by task tximage. +It will insert (in the tainsert task sense) one or more 1-D images into +rows of an existing 3-D table. Alternatively, it will create a 3-D table +from information taken either from a template 3-D table, or, if this table +is not supplied, from the input images themselves. Each image in the input +list is inserted as an array into a single cell at the specified row in the output table. + +Actions necessary to process the most complicated cases (e.g. when the +image length does not match the table array size) will be similar to the +ones described for task titable. + +If the output table does exist, insertion may take place in two ways. If the +output table name contains a column selector that selects a single column +in the table, all input images will be inserted in that column, starting +at the row pointed by task parameter "row". In a similar way as in task +titable, if "row" is negative or INDEF the task will look for the ORIG_ROW +keyword in the image header and use that keyword value for row number. +The second mode of insertion in an existing table is used if no matching +column selector is found in the output table name. In this case the task +will look for the columnar information written in the input image header by +task tximage, and use that information to place the image in the proper +column. If no columnar information exists in the header, or if the column +name in there does not match any column in the output table, the image is +skipped and the user warned. The "row" parameter processing works the same +way in this second mode. + +If the output table does not exist, the task will look for a template table +where to take column information from. If the template exists, the insertion +operation will be performed in an analogous way as above. Notice that the +result may be a single-column table if the template has a valid (matching) +column selector in its name, or a sparse table if not, because only the +actual input images will be stored in an otherwise empty table (the template +data is not copied into the output, only the column descriptors). + +If the template is missing, the task will attempt to retrieve columnar +information from the input image headers and build the output table with +enough columns and rows to fit all images in the list. Only images that +have columnar information in their headers can be processed, though. If +no images are found with the proper header keywords, no output takes place. +Notice that this task will not be able to handle the most generic case in +which a number of unspecified 1-D images with no proper header keywords +are input to create a 3-D table from scratch (without a template). + +The basic matching criterion is based on the column name. An error results +when datatypes in input image and output column do not agree. + +The task will be named "tiimage" following a former proposal for naming +the 3-D table utilities. + + + +2. Language: + +SPP, to allow the use of the generic datatype compiling facility, and to +reuse significant amounts of code already developed for other tasks in this +suite. + + + +3. Task parameters: + +Name Type What + +input image list/template list of 1D image names +outtable file name 3-D table name with optional column selector + (modified in place or created from scratch). +template file name template 3-D table name with optional column + selector +row int row in output table where to begin insertion. + + + +4. Data structures: + +The main data structure is a pointer-type column descriptor array. This +array is filled by information taken from the several possible sources +described above, and used by the tbtables routines to create and fill up +the output. + + + +5. Code structure: + +MAIN PROCEDURE: +- Read task parameters (clget). +- Decide which mode to use: mode = TMMODE (output name, template name) +- SWITCH mode +- CASE 1, 2: Output table exists. + - Break output table name into bracketed selectors (rdselect). + - Open output table (tbtopn with root name, READ_WRITE). + - Create array with either the single selected column pointer or all + column pointers (malloc, tcs_open). + - Alloc array of column pointers for output table. + - LOOP over all matched columns in tcs_ column array + - Translate pointer from tcs_ format to tbtables format (tcs_column) + - ENDLOOP + - TMLOOP (table pointer, column pointer array, rowpar, image list, mode). + - Close output table (tbtclo) + - Free array (mfree) +- END CASE +- CASE 3, 4: Output table does not exist but template table does exist. + - Break output table name into bracketed selectors (rdselect). + - Open output table (tbtopn with root name, NEW_FILE). + - Break template table name into bracketed selectors (rdselect). + - Open template table (tbtopn with root name, READ_ONLY). + - Create array with either the single selected column pointer or all + column pointers from template table (malloc, tcs_open). + - Alloc array of column pointers for output table. + - LOOP over all matched columns in template tcs_ column array + - Create column in output table (tcs_column, tbcinf, tbcdef) + - ENDLOOP + - Create output table (tbtcre). + - TMLOOP (table pointer, column pointer array, rowpar, image list, mode) + - Close template table (tbtclo) + - Close output table (tbtclo) + - Free arrays (mfree) +- CASE 5: Neither output nor template table exist. + - Alloc memory for strings. + - Alloc memory for column pointer array, assuming the worst case of each + input image in the list belonging to a separate, independent column. + - Open output table (tbtopn with root name, NEW_FILE). + - IFNOTERROR TMSCAN (table pointer, column pointer array, image list) + - Set mode = 2 to force TMLOOP to read column data from headers. + - Create output table (tbtcre). + - TMLOOP (table pointer, column pointer array, rowpar, image list, mode) + - ENDIF + - Close output table (tbtclo) + - Free arrays (mfree) +- END CASE +- CASE -1 + - Print error msg. + - Abort. +- END SWITCH +END MAIN + + + +PROCEDURE TMMODE: Detect mode of operation. + Input parameters: file name, template name (in full) + Return value: mode + + - IF output exists (access) + - mode = TMM1 (output file name, output type) + - IF mode == -1 + - Print error msg. + - return mode = -1 (error) + - ENDIF + - ELSE IF template does exist (access) + - mode = TMM1 (template file name, template type) + - IF mode == -1 + - Print error msg. + - return mode = -1 (error) + - ENDIF + - ELSE + mode = 5 + - ENDIF + return mode +END PROCEDURE + + + +PROCEDURE TMM1: Verify status of file and column selector. + Input parameters: file name, file type (output or template) + Return value: mode + + - IF file is not a table (whatfile). + - return mode = -1 (error) + - ENDIF + - Get bracket selector from file name (rdselect). + - Open table (tbtopn with root name, READ_ONLY). + - Get its total number of columns (tbpsta). + - Create array of column pointers from column selector (malloc, tcs_open). + - Close output table (tbtclo) + - Free array (mfree) + - IF output file type + - IF one column matched + - return mode = 1 + - ELSE + - return mode = 2 + - ENDIF + - ELSE IF template file type + - IF one column matched + - return mode = 3 + - ELSE + - return mode = 4 + - ENDIF + - ENDIF + return mode = -1 (error) +END PROCEDURE + + + +PROCEDURE TMLOOP: Scan input list and insert each image in turn. + Input parameters: table pointer, column pointer array,row, image list,mode + + - Initialize row counter. + - Initialize successful image counter. + - Open input list (imtopen) + - LOOP over input list (imtlen). + - Get image name (imtgetim). + - IFERROR Open input image (immap). + - Warn user. + - Skip image. + - ENDIF + - IF mode == 2 or mode == 4, look into image header for columnar info + and do the copy. + - IFERROR TMHC (table pointer, column pointer array, row, rowpar, + imio pointer) + - Close and skip image. + - ENDIF + - bump row and image counters. + - ELSE IF mode == 1 or mode == 3, just copy into single, fixed column. + - IFERROR TMCOPY (table pointer, column pointer, row, rowpar, + imio pointer) + - Warn user. + - Close and skip image. + - ENDIF + - bump row and image counters. + - ENDIF + - Close image (imunmap) + - ENDLOOP + - IF successful image counter == 0 + - Print error msg. + - ENDIF + - Close input list (imtclose) +END PROCEDURE + + + +PROCEDURE TMSCAN: Scan input list and create column pointer array from + information stored in image headers. + Input parameters: table pointer, column pointer array, its size, image list + Output parameter: actual number of matched columns. + + - Initialize column counter. + - Open input list (imtopen) + - LOOP over input list (imtlen). + - Get image name (imtgetim). + - IFERROR Open input image (immap). + - Warn user. + - Skip image. + - ENDIF + - IFERROR TMHEADER (imio pointer, column name, units, fmt, datatype, + lendata + - Warn user. + - Skip image. + - ENDIF + - IF there are defined columns (column counter > 0): + - match = false + - LOOP over defined columns + - Get column name (tbcinf) + - IF column name from table matches column name from header: + - match = true + - break + - ENDIF + - ENDLOOP + - IF no match, this is a new column: + - Define new column in array (tbcdef) + - Bump column counter + - ENDIF + - ELSE + - Define first new column in array (tbcdef) + - Bump column counter + - ENDIF + - ENDLOOP + - Close input list (imtclose) + - IF column counter == 0 + - Error. + - Create output table (tbtcre). +END PROCEDURE + + + +PROCEDURE TMHC: Get column name from image header and copy image into table. + Input parameters: table pointer, column pointer array, row, rowpar, + imio pointer + + - salloc space for column name. + - IFERROR TMHEADER (imio pointer, column name, etc.) + - Warn, return + - ENDIF + - match = false + - LOOP over table columns. + - IF column names match: + - IFERROR TMCOPY (table pointer, column pointer, row, rowpar, + imio pointer) + - Warn, return. + - ENDIF + - match = true + - ENDIF + - ENDLOOP + - IF no match + - Warn, return. + - ENDIF + - sfree +END PROCEDURE + + + +PROCEDURE TMCOPY: Copy image into designated row/column. + Input parameters: table pointer, column pointer, row, rowpar, imio pointer + + - Get table (tbcigi) and image (IM_PIXTYPE) pixel type. + - IF pixel type mismatch: + - Warn, return + - ENDIF + - Look for ORIG_ROW keyword (imaccf, imgeti). If found, and if "row" + parameter is negative or INDEF, supersede row counter. + - Get column array size (tbcinf) and image size (IM_NDIM, IM_LEN). + - Choose the minimum of these as the array size to be written to table. + - Read pixels in buffer (imgl1$t). ^ + - Write buffer into designated row/column (tbapt$t). | + - IF image is larger than array: | This goes into + - Warn user. | a generic data + - ELSE IF image is smaller than array: | type procedure + - Set remaining elements to INDEF (tbapt$t). | + - Warn user. | + - ENDIF v +END PROCEDURE + + + +PROCEDURE TMHEADER: Decode column info in image header. + Input parameter: imio pointer + Output parameter: column name, units, fmt, datatype, lendata + + - Look for COLDATA keyword (imaccf, imgstr). + - IF not found: + return error. + - ENDIF + - Parse and get parameters (sscan, gargwrd, gargi) + - IF error in nscan value: + return error. + - ENDIF +END PROCEDURE + + diff --git a/pkg/utilities/nttools/threed/tiimage/generic/mkpkg b/pkg/utilities/nttools/threed/tiimage/generic/mkpkg new file mode 100644 index 00000000..51bd24bb --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/generic/mkpkg @@ -0,0 +1,14 @@ +# Update the generic routines. + +default: + $checkout libpkg.a ../../ + $update libpkg.a + $checkin libpkg.a ../../ +$exit + +libpkg.a: + tmcp1s.x + tmcp1i.x + tmcp1r.x + tmcp1d.x + ; diff --git a/pkg/utilities/nttools/threed/tiimage/generic/tmcp1d.x b/pkg/utilities/nttools/threed/tiimage/generic/tmcp1d.x new file mode 100644 index 00000000..9670c6a6 --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/generic/tmcp1d.x @@ -0,0 +1,54 @@ + +# TM_CP1 -- Fill pixel buffer and copy into table. +# +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) + + +procedure tm_cp1d (im, tp, cp, row, lena, leni) + +pointer im # imio pointer +pointer tp # table pointer +pointer cp # column pointer +int row # row where to begin insertion +int lena # array length +int leni # image length +#-- +pointer buf +double undefd +real undefr +int undefi, i, len +short undefs + +pointer imgl1d() + +begin + # Read pixels into buffer. + buf = imgl1d (im) + + # Choose the minimum between image and table array + # lengths as the array size to be written to table. + len = min (lena, leni) + + # Write buffer into array cell element. + call tbaptd (tp, cp, row, Memd[buf], 1, len) + + # If image is smaller than array, set + # remaining elements to INDEF. + if (leni < lena) { + undefd = INDEFD + undefr = INDEFR + undefi = INDEFI + undefs = INDEFS + do i = len+1, lena + call tbaptd (tp, cp, row, undefd, i, 1) + } +end + + + + diff --git a/pkg/utilities/nttools/threed/tiimage/generic/tmcp1i.x b/pkg/utilities/nttools/threed/tiimage/generic/tmcp1i.x new file mode 100644 index 00000000..7e271952 --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/generic/tmcp1i.x @@ -0,0 +1,54 @@ + +# TM_CP1 -- Fill pixel buffer and copy into table. +# +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) + + +procedure tm_cp1i (im, tp, cp, row, lena, leni) + +pointer im # imio pointer +pointer tp # table pointer +pointer cp # column pointer +int row # row where to begin insertion +int lena # array length +int leni # image length +#-- +pointer buf +double undefd +real undefr +int undefi, i, len +short undefs + +pointer imgl1i() + +begin + # Read pixels into buffer. + buf = imgl1i (im) + + # Choose the minimum between image and table array + # lengths as the array size to be written to table. + len = min (lena, leni) + + # Write buffer into array cell element. + call tbapti (tp, cp, row, Memi[buf], 1, len) + + # If image is smaller than array, set + # remaining elements to INDEF. + if (leni < lena) { + undefd = INDEFD + undefr = INDEFR + undefi = INDEFI + undefs = INDEFS + do i = len+1, lena + call tbapti (tp, cp, row, undefi, i, 1) + } +end + + + + diff --git a/pkg/utilities/nttools/threed/tiimage/generic/tmcp1r.x b/pkg/utilities/nttools/threed/tiimage/generic/tmcp1r.x new file mode 100644 index 00000000..00594521 --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/generic/tmcp1r.x @@ -0,0 +1,54 @@ + +# TM_CP1 -- Fill pixel buffer and copy into table. +# +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) + + +procedure tm_cp1r (im, tp, cp, row, lena, leni) + +pointer im # imio pointer +pointer tp # table pointer +pointer cp # column pointer +int row # row where to begin insertion +int lena # array length +int leni # image length +#-- +pointer buf +double undefd +real undefr +int undefi, i, len +short undefs + +pointer imgl1r() + +begin + # Read pixels into buffer. + buf = imgl1r (im) + + # Choose the minimum between image and table array + # lengths as the array size to be written to table. + len = min (lena, leni) + + # Write buffer into array cell element. + call tbaptr (tp, cp, row, Memr[buf], 1, len) + + # If image is smaller than array, set + # remaining elements to INDEF. + if (leni < lena) { + undefd = INDEFD + undefr = INDEFR + undefi = INDEFI + undefs = INDEFS + do i = len+1, lena + call tbaptr (tp, cp, row, undefr, i, 1) + } +end + + + + diff --git a/pkg/utilities/nttools/threed/tiimage/generic/tmcp1s.x b/pkg/utilities/nttools/threed/tiimage/generic/tmcp1s.x new file mode 100644 index 00000000..3d308f13 --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/generic/tmcp1s.x @@ -0,0 +1,54 @@ + +# TM_CP1 -- Fill pixel buffer and copy into table. +# +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) + + +procedure tm_cp1s (im, tp, cp, row, lena, leni) + +pointer im # imio pointer +pointer tp # table pointer +pointer cp # column pointer +int row # row where to begin insertion +int lena # array length +int leni # image length +#-- +pointer buf +double undefd +real undefr +int undefi, i, len +short undefs + +pointer imgl1s() + +begin + # Read pixels into buffer. + buf = imgl1s (im) + + # Choose the minimum between image and table array + # lengths as the array size to be written to table. + len = min (lena, leni) + + # Write buffer into array cell element. + call tbapts (tp, cp, row, Mems[buf], 1, len) + + # If image is smaller than array, set + # remaining elements to INDEF. + if (leni < lena) { + undefd = INDEFD + undefr = INDEFR + undefi = INDEFI + undefs = INDEFS + do i = len+1, lena + call tbapts (tp, cp, row, undefs, i, 1) + } +end + + + + diff --git a/pkg/utilities/nttools/threed/tiimage/list.tex b/pkg/utilities/nttools/threed/tiimage/list.tex new file mode 100644 index 00000000..05eb3592 --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/list.tex @@ -0,0 +1,789 @@ +\documentstyle{article} +\topmargin -30mm +\textheight 250mm +\oddsidemargin -5mm +\evensidemargin -5mm +\textwidth 170mm + +\begin{document} + +\tableofcontents + +\newpage + +\addcontentsline{toc}{section}{loc.txt} +\begin{verbatim} + +Filename Total Blanks Comments Help Execute Nonexec +============================================================================ + tiimage.h 9 1 0 0 0 8 + tiimage.x 141 36 31 0 53 21 + tmloop.x 96 23 15 0 40 18 + tmmode.x 108 24 24 0 30 30 + tmscan.x 92 21 15 0 38 18 + tmheader.x 59 19 8 0 19 13 + tmhc.x 54 16 9 0 15 14 + tmcopy.x 63 18 9 0 23 13 + tmcp1.gx 53 17 11 0 10 15 +TOTAL 834 226 155 0 258 195 +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{tiimage.h} +\begin{verbatim} + +define OUTPUT_TYPE 1 # Output-type file +define TEMPLATE_TYPE 2 # Template-type file + +define MODE_OUT_SINGLE 1 # Output with single column +define MODE_OUT_ALL 2 # Output with all columns +define MODE_TEM_SINGLE 3 # Template with single column +define MODE_TEM_ALL 4 # Template with all columns +define MODE_SCRATCH 5 # No output nor template, create from scratch +define MODE_ERROR -1 +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{tiimage.x} +\begin{verbatim} + +include +include "tiimage.h" + +# TIIMAGE -- Insert 1D images into 3D table rows. +# +# Input images are given by a filename template list. The output is a +# 3D table with optional column selector. +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) + + +procedure t_tiimage() + +char imlist[SZ_LINE] # Input image list +char output[SZ_PATHNAME] # Output table name +char template[SZ_PATHNAME] # Template table name +int row # Row where to begin insertion +bool verbose # Print operations ? +#-- +char root[SZ_FNAME] # String storage areas used +char rs[SZ_FNAME] # by row/column selector +char cs[SZ_FNAME] # mechanism +char cn[SZ_COLNAME] +char cu[SZ_COLUNITS] +char cf[SZ_COLFMT] +pointer sp, otp, ttp, ocp, tcp, newocp, tempp, list +int nocp, mode, numcol, dtyp, lend, lenf, cnum, i + +pointer tbtopn(), tcs_column(), imtopen() +int clgeti(), tbpsta(), tm_mode(), imtlen() +bool clgetb(), streq() + +begin + # Get task parameters. + call clgstr ("input", imlist, SZ_LINE) + call clgstr ("outtable", output, SZ_PATHNAME) + call clgstr ("template", template, SZ_PATHNAME) + row = clgeti ("row") + verbose = clgetb ("verbose") + + # Abort if invalid output name. + if (streq (output, "STDOUT")) + call error (1, "Invalid output file name.") + + # Decide which mode to use. + mode = tm_mode (output, template, root, rs, cs, cn, cu, cf) + + call smark (sp) + switch (mode) { + + case MODE_OUT_SINGLE,MODE_OUT_ALL: + + # Break output table name into bracketed selectors. + call rdselect (output, root, rs, cs, SZ_PATHNAME) + + # Open output table. + otp = tbtopn (root, READ_WRITE, 0) + + # Create arrays with selected column pointer(s). + numcol = tbpsta (otp, TBL_NCOLS) + call salloc (ocp, numcol, TY_INT) + call salloc (newocp, numcol, TY_INT) + call tcs_open (otp, cs, Memi[ocp], nocp, numcol) + + # Translate pointer to tbtables-compatible format. + do i = 1, nocp + Memi[newocp+i-1] = tcs_column (Memi[ocp+i-1]) + + # Do the insertion by looping over all input images. + call tm_loop (otp, newocp, nocp, row, imlist, mode, output, + verbose) + + # Close output table. + call tbtclo (otp) + + case MODE_TEM_SINGLE,MODE_TEM_ALL: + + # Get output table root name and open it. + call rdselect (output, root, rs, cs, SZ_PATHNAME) + otp = tbtopn (root, NEW_FILE, 0) + + # Break template table name into bracketed + # selectors and open it. + call rdselect (template, root, rs, cs, SZ_PATHNAME) + ttp = tbtopn (root, READ_ONLY, 0) + + # Create arrays with selected column pointer(s). + numcol = tbpsta (ttp, TBL_NCOLS) + call salloc (tcp, numcol, TY_INT) + call salloc (newocp, numcol, TY_INT) + call tcs_open (ttp, cs, Memi[tcp], nocp, numcol) + + # Copy column info from template to output table. + do i = 1, nocp { + tempp = tcs_column (Memi[tcp+i-1]) + call tbcinf (tempp, cnum, cn, cu, cf, dtyp, lend, lenf) + call tbcdef (otp, tempp, cn, cu, cf, dtyp, lend, 1) + Memi[newocp+i-1] = tempp + } + + # Create output and close template. + call tbtcre (otp) + call tbtclo (ttp) + + # Do the insertion by looping over all input images. + call tm_loop (otp, newocp, nocp, row, imlist, mode, output, + verbose) + + # Close output table. + call tbtclo (otp) + + case MODE_SCRATCH: + + # Alloc memory for column pointer array, assuming + # the worst case of each input image in the list + # belonging to a separate column. + list = imtopen (imlist) + numcol = imtlen (list) + call imtclose (list) + call salloc (newocp, numcol, TY_INT) + + # Open output table. + call rdselect (output, root, rs, cs, SZ_PATHNAME) + otp = tbtopn (root, NEW_FILE, 0) + + # Build column descriptor array from info in image headers. + ifnoerr (call tm_scan (otp, newocp, numcol, nocp, imlist)) { + + # Pretend that template table exists and do the insertion. + mode = MODE_TEM_ALL + call tm_loop (otp, newocp, nocp, row, imlist, mode, output, + verbose) + } + + # Close output table. + call tbtclo (otp) + + case MODE_ERROR: + call error (1, "Cannot process.") + } + + call sfree (sp) +end +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{tmloop.x} +\begin{verbatim} + +include +include "tiimage.h" + +# TM_LOOP -- Scan input list and insert each image in turn. +# +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) + + +procedure tm_loop (tp, cp, ncp, row, imlist, mode, outname, verbose) + +pointer tp # table pointer +pointer cp # column pointer array +int ncp # size of column pointer array +int row # row where to begin insertion +char imlist[ARB] # input image list +int mode # operating mode +char outname[ARB] # output table name (for listing only) +bool verbose # print info ? +#-- +pointer sp, im, list, fname +int i, rowc, imc, image +bool rflag + +errchk immap, tm_hc, tm_copy + +pointer immap(), imtopen() +int imtlen(), imtgetim() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # Initialize row counter. + rowc = row + rflag = false + if (rowc <= 0 || IS_INDEFI(rowc)) rflag = true + + # Initialize successful image counter. + imc = 0 + + # Open input list. + list = imtopen (imlist) + + # Loop over input list. + do image = 1, imtlen(list) { + + # Get input image name and open it. Skip if error. + i = imtgetim (list, Memc[fname], SZ_PATHNAME) + iferr (im = immap (Memc[fname], READ_ONLY, 0)) { + call erract (EA_WARN) + next + } + if (verbose) { + call printf ("%s ") + call pargstr (Memc[fname]) + call flush (STDOUT) + } + + # Look into image header for columnar info and do the copy. + if (mode == MODE_OUT_ALL || mode == MODE_TEM_ALL) { + iferr (call tm_hc (tp, cp, ncp, rowc, rflag, im)) { + call erract (EA_WARN) + call imunmap (im) + next + } + + # Bump row and image counters. + rowc = rowc + 1 + imc = imc + 1 + + # Just copy into single column. + } else if (mode == MODE_OUT_SINGLE || mode == MODE_TEM_SINGLE) { + iferr (call tm_copy (tp, Memi[cp], rowc, rflag, im)) { + call erract (EA_WARN) + call imunmap (im) + next + } + + # Bump row and image counters. + rowc = rowc + 1 + imc = imc + 1 + } + + if (verbose) { + call printf ("-> %s row=%d \n") + call pargstr (outname) + call pargi (rowc-1) + call flush (STDOUT) + } + + # Close current image. + call imunmap (im) + } + + call imtclose (list) + call sfree (sp) + if (imc == 0) + call error (1, "No images were inserted.") +end +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{tmmode.x} +\begin{verbatim} + +include +include "../whatfile.h" +include "tiimage.h" + +# TM_MODE -- Detect mode of operation. +# +# There are five possible modes: +# 1 - Output table exists and one column was selected. +# 2 - Output table exists and no valid column was selected. +# 3 - Output table does not exist but template exists and one column was +# selected. +# 4 - Output table does not exist but template exists and no valid column +# was selected. +# 5 - New table has to be created from scratch. +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) + + +int procedure tm_mode (output, template, root, rs, cs, cn, cu, cf) + +char output[SZ_PATHNAME] +char template[SZ_PATHNAME] +char root[SZ_FNAME] +char rs[SZ_FNAME] +char cs[SZ_FNAME] +char cn[SZ_COLNAME] +char cu[SZ_COLUNITS] +char cf[SZ_COLFMT] +#- +int mode + +int access(), tm_m1() + +begin + # Process output name. Notice that routine access() must be + # supplied with only the root name in order to succeed. + call rdselect (output, root, rs, cs, SZ_PATHNAME) + if (access (root, READ_WRITE, 0) == YES) { + mode = tm_m1 (OUTPUT_TYPE, root,rs,cs,cn,cu,cf) + if (mode == MODE_ERROR) + call error (1, "Cannot use output file.") + + # If no valid output, try with template name. + } else { + call rdselect (template, root, rs, cs, SZ_PATHNAME) + if (access (root, READ_ONLY, 0) == YES) { + mode = tm_m1 (TEMPLATE_TYPE, root, rs, cs, cn, cu, cf) + if (mode == MODE_ERROR) + call error (1, "Cannot use template file.") + } else { + mode = MODE_SCRATCH + } + } + + return (mode) +end + + +# TM_M1 -- Verify status of file and column selector. + +int procedure tm_m1 (type, root, rs, cs, cn, cu, cf) + +int type +char root[SZ_FNAME] +char rs[SZ_FNAME] +char cs[SZ_FNAME] +char cn[SZ_COLNAME] +char cu[SZ_COLUNITS] +char cf[SZ_COLFMT] +#- +pointer tp, cp +int numcol, ncp + +pointer tbtopn() +int whatfile(), tbpsta() + +begin + # Test if it is a valid table. + if (whatfile (root) != IS_TABLE) + return (MODE_ERROR) + + # Open table + tp = tbtopn (root, READ_ONLY) + + # Get its total number of columns. + numcol = tbpsta (tp, TBL_NCOLS) + + # Create array of column pointers from column selector. + # This is just to get the actual number of selected columns. + call malloc (cp, numcol, TY_INT) + call tcs_open (tp, cs, Memi[cp], ncp, numcol) + call tbtclo (tp) + call mfree (cp) + + # Decide mode. + if (type == OUTPUT_TYPE) { + if (ncp == 1) + return (MODE_OUT_SINGLE) + else + return (MODE_OUT_ALL) + } else if (type == TEMPLATE_TYPE) { + if (ncp == 1) + return (MODE_TEM_SINGLE) + else + return (MODE_TEM_ALL) + } + return (MODE_ERROR) +end + + +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{tmscan.x} +\begin{verbatim} + +include +include +include + +# TM_SCAN -- Scan input image list and create column pointer array +# and table from information stored in image headers. +# +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) + + +procedure tm_scan (otp, ocp, ocpsize, nocp, imlist) + +pointer otp # i: output table pointer +pointer ocp # io: output table column pointer array +int ocpsize # i: size of above array +int nocp # o: actual number of columns in array +char imlist[ARB] # i: input image list +#-- +pointer sp, im, list +pointer imname, cn, cn1, cu, cf, duma +int image, column, lendata, dumi, i +bool match + +errchk tm_header + +pointer imtopen(), immap() +int imtlen(), imtgetim() +bool streq() + +begin + call smark (sp) + call salloc (imname, SZ_PATHNAME, TY_CHAR) + call salloc (cn, SZ_COLNAME, TY_CHAR) + call salloc (cn1, SZ_COLNAME, TY_CHAR) + call salloc (cu, SZ_COLUNITS, TY_CHAR) + call salloc (cf, SZ_COLFMT, TY_CHAR) + call salloc (duma, max(SZ_COLUNITS,SZ_COLFMT),TY_CHAR) + + # Open input list and initialize number of columns. + list = imtopen (imlist) + nocp = 0 + + # Scan input list. + do image = 1, imtlen(list) { + + # Open image. + i = imtgetim (list, Memc[imname], SZ_PATHNAME) + iferr (im = immap (Memc[imname], READ_ONLY, 0)) { + call erract (EA_WARN) + next + } + + # Get column data from image header. + iferr (call tm_header (im, Memc[cn], Memc[cu], Memc[cf])) { + call erract (EA_WARN) + next + } + + # Array size is full image size. + lendata = 0 + do i = 1, IM_NDIM(im) + lendata = lendata + IM_LEN(im,i) + + if (nocp > 0) { + + # See if column name from header matches any name + # already stored in column pointer array. + match = false + do column = 1, nocp { + call tbcinf (Memi[ocp+column-1], dumi, Memc[cn1], + Memc[duma], Memc[duma], dumi, dumi, dumi) + if (streq (Memc[cn1], Memc[cn])) { + match = true + break + } + } + if (!match) { + + # No names matched, efine new column. + call tbcdef (otp, Memi[ocp+nocp], Memc[cn], Memc[cu], + Memc[cf], IM_PIXTYPE(im), lendata, 1) + nocp = nocp + 1 + } + } else { + + # Array is empty, define first column. + call tbcdef (otp, Memi[ocp], Memc[cn], Memc[cu], Memc[cf], + IM_PIXTYPE(im), lendata, 1) + nocp = 1 + } + } + + call imtclose (list) + call sfree (sp) + if (nocp == 0) + call error (1, "No images with column data in header.") + call tbtcre (otp) +end +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{tmheader.x} +\begin{verbatim} + +include + +# TM_HEADER -- Decode column info in image header. +# +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) + + +procedure tm_header (im, colname, colunits, colfmt) + +pointer im # image pointer +char colname[SZ_COLNAME] # column name +char colunits[SZ_COLUNITS] # column units +char colfmt[SZ_COLFMT] # column print format +#-- +pointer sp, kwval +int colnum + +string corrupt "Corrupted header in input image." + +bool streq() +int imaccf(), nscan() + +begin + if (imaccf (im, "COLDATA") == NO) + call error (1, "No column information in image header.") + + call smark (sp) + call salloc (kwval, SZ_LINE, TY_CHAR) + + # Get keyword value. + call imgstr (im, "COLDATA", Memc[kwval], SZ_LINE) + + # Read fields. + call sscan (Memc[kwval]) + call gargi (colnum) + if (nscan() < 1) call error (1, corrupt) + call gargwrd (colname, SZ_COLNAME) + if (nscan() < 1) call error (1, corrupt) + call gargwrd (colunits, SZ_COLUNITS) + if (nscan() < 1) call error (1, corrupt) + call gargwrd (colfmt, SZ_COLFMT) + if (nscan() < 1) call error (1, corrupt) + + # Decode custom-encoded values. + if (streq (colunits, "default")) + call strcpy ("", colunits, SZ_COLUNITS) + if (streq (colfmt, "default")) + call strcpy ("", colfmt, SZ_COLFMT) + + call sfree (sp) +end + + + +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{tmhc.x} +\begin{verbatim} + +include + +# TM_HC -- Get column name from image header and copy image into table. +# +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) + + +procedure tm_hc (tp, cp, ncp, row, rflag, im) + +pointer tp # table pointer +pointer cp # column pointer array +int ncp # size of column pointer array +int row # row where to begin insertion +bool rflag # use row number in header ? +pointer im # image pointer +#-- +pointer sp, colname, cn, duma +int i, dumi +bool match + +errchk tm_header, tm_copy + +bool streq() + +begin + call smark (sp) + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (cn, SZ_COLNAME, TY_CHAR) + call salloc (duma, max(SZ_COLUNITS,SZ_COLFMT),TY_CHAR) + + # Get column name from image header. + call tm_header (im, Memc[colname], Memc[duma], Memc[duma]) + + # Loop over table columns. + match = false + do i = 1, ncp { + + # Get column name from table. + call tbcinf (Memi[cp+i-1], dumi, Memc[cn], Memc[duma], + Memc[duma], dumi, dumi, dumi) + + # Copy array if names match. + if (streq (Memc[colname], Memc[cn])) { + call tm_copy (tp, Memi[cp+i-1], row, rflag, im) + match = true + } + } + if (!match) + call error (1, "No column matched.") + + call sfree (sp) +end +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{tmcopy.x} +\begin{verbatim} + +include +include + +# TM_COPY -- Copy image into designated row/column. +# +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) + + +procedure tm_copy (tp, cp, row, rflag, im) + +pointer tp # table pointer +pointer cp # column pointer +int row # row where to begin insertion +bool rflag # use row number in image header ? +pointer im # imio pointer +#-- +pointer sp, duma +int i, lena, leni, dumi + +int tbcigi(), imgeti(), imaccf() + +begin + # See if table and image pixel types match. + if (tbcigi (tp, TBL_COL_DATATYPE) == IM_PIXTYPE(im)) + call error (1, "Pixel type mismatch.") + + # Look for row information in image header. + if (imaccf (im, "ORIG_ROW") == YES) { + if (rflag) + row = imgeti (im, "ORIG_ROW") + } + + # Get column array size and image size. + call smark (sp) + call salloc (duma, max(max(SZ_COLNAME,SZ_COLUNITS),SZ_COLFMT),TY_CHAR) + call tbcinf (cp, dumi, Memc[duma], Memc[duma], Memc[duma], dumi, + lena, dumi) + call sfree (sp) + leni = 0 + do i = 1, IM_NDIM(im) + leni = leni + IM_LEN(im,i) + + # Copy. + switch (IM_PIXTYPE(im)) { + case TY_SHORT: + call tm_cp1s (im, tp, cp, row, lena, leni) + case TY_INT: + call tm_cp1i (im, tp, cp, row, lena, leni) + case TY_REAL: + call tm_cp1r (im, tp, cp, row, lena, leni) + case TY_DOUBLE: + call tm_cp1d (im, tp, cp, row, lena, leni) + default: + call error (1, "Non-supported data type.") + } + +end + + + + +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{tmcp1.gx} +\begin{verbatim} + + +# TM_CP1 -- Fill pixel buffer and copy into table. +# +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) + + +procedure tm_cp1$t (im, tp, cp, row, lena, leni) + +pointer im # imio pointer +pointer tp # table pointer +pointer cp # column pointer +int row # row where to begin insertion +int lena # array length +int leni # image length +#-- +pointer buf +double undefd +real undefr +int undefi, i, len +short undefs + +pointer imgl1$t() + +begin + # Read pixels into buffer. + buf = imgl1$t (im) + + # Choose the minimum between image and table array + # lengths as the array size to be written to table. + len = min (lena, leni) + + # Write buffer into array cell element. + call tbapt$t (tp, cp, row, Mem$t[buf], 1, len) + + # If image is smaller than array, set + # remaining elements to INDEF. + if (leni < lena) { + undefd = INDEFD + undefr = INDEFR + undefi = INDEFI + undefs = INDEFS + do i = len+1, lena + call tbapt$t (tp, cp, row, undef$t, i, 1) + } +end + + + + +\end{verbatim} +\newpage +\end{document} diff --git a/pkg/utilities/nttools/threed/tiimage/list.toc b/pkg/utilities/nttools/threed/tiimage/list.toc new file mode 100644 index 00000000..06d86919 --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/list.toc @@ -0,0 +1,10 @@ +\contentsline {section}{loc.txt}{2} +\contentsline {section}{tiimage.h}{3} +\contentsline {section}{tiimage.x}{4} +\contentsline {section}{tmloop.x}{7} +\contentsline {section}{tmmode.x}{9} +\contentsline {section}{tmscan.x}{11} +\contentsline {section}{tmheader.x}{13} +\contentsline {section}{tmhc.x}{15} +\contentsline {section}{tmcopy.x}{16} +\contentsline {section}{tmcp1.gx}{18} diff --git a/pkg/utilities/nttools/threed/tiimage/loc.txt b/pkg/utilities/nttools/threed/tiimage/loc.txt new file mode 100644 index 00000000..43db97fc --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/loc.txt @@ -0,0 +1,12 @@ +Filename Total Blanks Comments Help Execute Nonexec +============================================================================ + tiimage.h 9 1 0 0 0 8 + tiimage.x 141 36 31 0 53 21 + tmloop.x 96 23 15 0 40 18 + tmmode.x 108 24 24 0 30 30 + tmscan.x 92 21 15 0 38 18 + tmheader.x 59 19 8 0 19 13 + tmhc.x 54 16 9 0 15 14 + tmcopy.x 63 18 9 0 23 13 + tmcp1.gx 53 17 11 0 10 15 +TOTAL 834 226 155 0 258 195 diff --git a/pkg/utilities/nttools/threed/tiimage/mkpkg b/pkg/utilities/nttools/threed/tiimage/mkpkg new file mode 100644 index 00000000..6a3588af --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/mkpkg @@ -0,0 +1,29 @@ +# Update the tiimage application code in the threed package library. +# Author: I.Busko, 30-Jan-1997 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +# This module is called from the threed mkpkg. +generic: + $ifnfile (generic/tmcp1i.x) + $generic -k -p generic/ -t sird tmcp1.gx + $endif + $ifolder (generic/tmcp1i.x, tmcp1.gx) + $generic -k -p generic/ -t sird tmcp1.gx + $endif + ; + +libpkg.a: + @generic + tiimage.x tiimage.h + tmcopy.x + tmhc.x + tmheader.x + tmloop.x tiimage.h + tmmode.x tiimage.h + tmscan.x + ; + diff --git a/pkg/utilities/nttools/threed/tiimage/tiimage.h b/pkg/utilities/nttools/threed/tiimage/tiimage.h new file mode 100644 index 00000000..86e0d000 --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/tiimage.h @@ -0,0 +1,9 @@ +define OUTPUT_TYPE 1 # Output-type file +define TEMPLATE_TYPE 2 # Template-type file + +define MODE_OUT_SINGLE 1 # Output with single column +define MODE_OUT_ALL 2 # Output with all columns +define MODE_TEM_SINGLE 3 # Template with single column +define MODE_TEM_ALL 4 # Template with all columns +define MODE_SCRATCH 5 # No output nor template, create from scratch +define MODE_ERROR -1 diff --git a/pkg/utilities/nttools/threed/tiimage/tiimage.x b/pkg/utilities/nttools/threed/tiimage/tiimage.x new file mode 100644 index 00000000..85aab676 --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/tiimage.x @@ -0,0 +1,147 @@ +include +include "tiimage.h" + +# TIIMAGE -- Insert 1D images into 3D table rows. +# +# Input images are given by a filename template list. The output is a +# 3D table with optional column selector. +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) + + +procedure t_tiimage() + +char imlist[SZ_LINE] # Input image list +char output[SZ_PATHNAME] # Output table name +char template[SZ_PATHNAME] # Template table name +int row # Row where to begin insertion +bool verbose # Print operations ? +#-- +char root[SZ_FNAME] # String storage areas used +char rs[SZ_FNAME] # by row/column selector +char cs[SZ_FNAME] # mechanism +char cn[SZ_COLNAME] +char cu[SZ_COLUNITS] +char cf[SZ_COLFMT] +pointer sp, otp, ttp, ocp, tcp, newocp, tempp, list +int nocp, mode, numcol, dtyp, lend, lenf, cnum, i + +pointer tbtopn(), tcs_column(), imtopen() +int clgeti(), tbpsta(), tm_mode(), imtlen() +bool clgetb(), streq() + +begin + # Get task parameters. + call clgstr ("input", imlist, SZ_LINE) + call clgstr ("outtable", output, SZ_PATHNAME) + call clgstr ("template", template, SZ_PATHNAME) + row = clgeti ("row") + verbose = clgetb ("verbose") + + # Abort if invalid output name. + if (streq (output, "STDOUT")) + call error (1, "Invalid output file name.") + + # Decide which mode to use. + mode = tm_mode (output, template, root, rs, cs, cn, cu, cf) + + call smark (sp) + switch (mode) { + + case MODE_OUT_SINGLE,MODE_OUT_ALL: + + # Break output table name into bracketed selectors. + call rdselect (output, root, rs, cs, SZ_PATHNAME) + + # Open output table. + otp = tbtopn (root, READ_WRITE, 0) + + # Create arrays with selected column pointer(s). + numcol = tbpsta (otp, TBL_NCOLS) + call salloc (ocp, numcol, TY_INT) + call salloc (newocp, numcol, TY_INT) + call tcs_open (otp, cs, Memi[ocp], nocp, numcol) + + # Translate pointer to tbtables-compatible format. + do i = 1, nocp + Memi[newocp+i-1] = tcs_column (Memi[ocp+i-1]) + + # Do the insertion by looping over all input images. + call tm_loop (otp, newocp, nocp, row, imlist, mode, output, + verbose) + + # Close output table. + call tbtclo (otp) + + case MODE_TEM_SINGLE,MODE_TEM_ALL: + + # Get output table root name and open it. + call rdselect (output, root, rs, cs, SZ_PATHNAME) + otp = tbtopn (root, NEW_FILE, 0) + + # Break template table name into bracketed + # selectors and open it. + call rdselect (template, root, rs, cs, SZ_PATHNAME) + ttp = tbtopn (root, READ_ONLY, 0) + + # Create arrays with selected column pointer(s). + numcol = tbpsta (ttp, TBL_NCOLS) + call salloc (tcp, numcol, TY_INT) + call salloc (newocp, numcol, TY_INT) + call tcs_open (ttp, cs, Memi[tcp], nocp, numcol) + + # Copy column info from template to output table. + do i = 1, nocp { + tempp = tcs_column (Memi[tcp+i-1]) + call tbcinf (tempp, cnum, cn, cu, cf, dtyp, lend, lenf) + call tbcdef (otp, tempp, cn, cu, cf, dtyp, lend, 1) + Memi[newocp+i-1] = tempp + } + + # Create output and close template. + call tbtcre (otp) + call tbtclo (ttp) + + # Do the insertion by looping over all input images. + call tm_loop (otp, newocp, nocp, row, imlist, mode, output, + verbose) + + # Close output table. + call tbtclo (otp) + + case MODE_SCRATCH: + + # Alloc memory for column pointer array, assuming + # the worst case of each input image in the list + # belonging to a separate column. + list = imtopen (imlist) + numcol = imtlen (list) + call imtclose (list) + call salloc (newocp, numcol, TY_INT) + + # Open output table. + call rdselect (output, root, rs, cs, SZ_PATHNAME) + otp = tbtopn (root, NEW_FILE, 0) + + # Build column descriptor array from info in image headers. + ifnoerr (call tm_scan (otp, newocp, numcol, nocp, imlist)) { + + # Pretend that template table exists and do the insertion. + mode = MODE_TEM_ALL + call tm_loop (otp, newocp, nocp, row, imlist, mode, output, + verbose) + } + + # Close output table. + call tbtclo (otp) + + case MODE_ERROR: + call error (1, "Cannot process.") + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/threed/tiimage/tmcopy.x b/pkg/utilities/nttools/threed/tiimage/tmcopy.x new file mode 100644 index 00000000..8d2673c5 --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/tmcopy.x @@ -0,0 +1,67 @@ +include +include + +# TM_COPY -- Copy image into designated row/column. +# +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) +# 21-May-97 - Changes from code review (IB) + + +procedure tm_copy (tp, cp, row, rflag, im) + +pointer tp # table pointer +pointer cp # column pointer +int row # row where to begin insertion +bool rflag # use row number in image header ? +pointer im # imio pointer +#-- +pointer sp, duma +int i, lena, leni, dumi + +int tbcigi(), imgeti(), imaccf() + +begin + # See if table and image pixel types match. + if (tbcigi (tp, TBL_COL_DATATYPE) == IM_PIXTYPE(im)) + call error (1, "Pixel type mismatch.") + + # Look for row information in image header. + if (imaccf (im, "ORIG_ROW") == YES) { + if (rflag) + row = imgeti (im, "ORIG_ROW") + } + + # Get column array size and image size. + call smark (sp) + call salloc (duma, max(max(SZ_COLNAME,SZ_COLUNITS),SZ_COLFMT),TY_CHAR) + call tbcinf (cp, dumi, Memc[duma], Memc[duma], Memc[duma], dumi, + lena, dumi) + call sfree (sp) + leni = 1 + do i = 1, IM_NDIM(im) + leni = leni * IM_LEN(im,i) + + # Copy. + switch (IM_PIXTYPE(im)) { + case TY_SHORT: + call tm_cp1s (im, tp, cp, row, lena, leni) + case TY_INT: + call tm_cp1i (im, tp, cp, row, lena, leni) + case TY_REAL: + call tm_cp1r (im, tp, cp, row, lena, leni) + case TY_DOUBLE: + call tm_cp1d (im, tp, cp, row, lena, leni) + default: + call error (1, "Non-supported data type.") + } + +end + + + + diff --git a/pkg/utilities/nttools/threed/tiimage/tmcp1.gx b/pkg/utilities/nttools/threed/tiimage/tmcp1.gx new file mode 100644 index 00000000..b90ca406 --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/tmcp1.gx @@ -0,0 +1,54 @@ + +# TM_CP1 -- Fill pixel buffer and copy into table. +# +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) + + +procedure tm_cp1$t (im, tp, cp, row, lena, leni) + +pointer im # imio pointer +pointer tp # table pointer +pointer cp # column pointer +int row # row where to begin insertion +int lena # array length +int leni # image length +#-- +pointer buf +double undefd +real undefr +int undefi, i, len +short undefs + +pointer imgl1$t() + +begin + # Read pixels into buffer. + buf = imgl1$t (im) + + # Choose the minimum between image and table array + # lengths as the array size to be written to table. + len = min (lena, leni) + + # Write buffer into array cell element. + call tbapt$t (tp, cp, row, Mem$t[buf], 1, len) + + # If image is smaller than array, set + # remaining elements to INDEF. + if (leni < lena) { + undefd = INDEFD + undefr = INDEFR + undefi = INDEFI + undefs = INDEFS + do i = len+1, lena + call tbapt$t (tp, cp, row, undef$t, i, 1) + } +end + + + + diff --git a/pkg/utilities/nttools/threed/tiimage/tmhc.x b/pkg/utilities/nttools/threed/tiimage/tmhc.x new file mode 100644 index 00000000..30ad4eb3 --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/tmhc.x @@ -0,0 +1,57 @@ +include + +# TM_HC -- Get column name from image header and copy image into table. +# +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) + + +procedure tm_hc (tp, cp, ncp, row, rflag, im) + +pointer tp # table pointer +pointer cp # column pointer array +int ncp # size of column pointer array +int row # row where to begin insertion +bool rflag # use row number in header ? +pointer im # image pointer +#-- +pointer sp, colname, cn, duma +int i, dumi +bool match + +errchk tm_header, tm_copy + +bool streq() + +begin + call smark (sp) + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (cn, SZ_COLNAME, TY_CHAR) + call salloc (duma, max(SZ_COLUNITS,SZ_COLFMT),TY_CHAR) + + # Get column name from image header. + call tm_header (im, Memc[colname], Memc[duma], Memc[duma]) + + # Loop over table columns. + match = false + do i = 1, ncp { + + # Get column name from table. + call tbcinf (Memi[cp+i-1], dumi, Memc[cn], Memc[duma], + Memc[duma], dumi, dumi, dumi) + + # Copy array if names match. + if (streq (Memc[colname], Memc[cn])) { + call tm_copy (tp, Memi[cp+i-1], row, rflag, im) + match = true + } + } + if (!match) + call error (1, "No column matched.") + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/threed/tiimage/tmheader.x b/pkg/utilities/nttools/threed/tiimage/tmheader.x new file mode 100644 index 00000000..b6481fa4 --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/tmheader.x @@ -0,0 +1,60 @@ +include + +# TM_HEADER -- Decode column info in image header. +# +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) +# 21-May-97 - Changes from code review (IB) + + +procedure tm_header (im, colname, colunits, colfmt) + +pointer im # image pointer +char colname[SZ_COLNAME] # column name +char colunits[SZ_COLUNITS] # column units +char colfmt[SZ_COLFMT] # column print format +#-- +pointer sp, kwval +int colnum + +string corrupt "Corrupted header in input image." + +bool streq() +int imaccf(), nscan() + +begin + if (imaccf (im, "COLDATA") == NO) + call error (1, "No column information in image header.") + + call smark (sp) + call salloc (kwval, SZ_LINE, TY_CHAR) + + # Get keyword value. + call imgstr (im, "COLDATA", Memc[kwval], SZ_LINE) + + # Read fields. + call sscan (Memc[kwval]) + call gargi (colnum) + if (nscan() < 1) call error (1, corrupt) + call gargwrd (colname, SZ_COLNAME) + if (nscan() < 1) call error (1, corrupt) + call gargwrd (colunits, SZ_COLUNITS) + if (nscan() < 1) call error (1, corrupt) + call gargwrd (colfmt, SZ_COLFMT) + if (nscan() < 1) call error (1, corrupt) + + # Decode custom-encoded values. + if (streq (colunits, "default")) + colunits[1] = EOS + if (streq (colfmt, "default")) + colfmt[1] = EOS + + call sfree (sp) +end + + + diff --git a/pkg/utilities/nttools/threed/tiimage/tmloop.x b/pkg/utilities/nttools/threed/tiimage/tmloop.x new file mode 100644 index 00000000..e99d8e8b --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/tmloop.x @@ -0,0 +1,104 @@ +include +include "tiimage.h" + +# TM_LOOP -- Scan input list and insert each image in turn. +# +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) + + +procedure tm_loop (tp, cp, ncp, row, imlist, mode, outname, verbose) + +pointer tp # table pointer +pointer cp # column pointer array +int ncp # size of column pointer array +int row # row where to begin insertion +char imlist[ARB] # input image list +int mode # operating mode +char outname[ARB] # output table name (for listing only) +bool verbose # print info ? +#-- +pointer sp, im, list, fname +int i, rowc, imc, image +bool rflag + +errchk immap, tm_hc, tm_copy + +pointer immap(), imtopen() +int imtlen(), imtgetim() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # Initialize row counter. + rowc = row + rflag = false + if (rowc <= 0 || IS_INDEFI(rowc)) rflag = true + + # Initialize successful image counter. + imc = 0 + + # Open input list. + list = imtopen (imlist) + + # Loop over input list. + do image = 1, imtlen(list) { + + # Get input image name and open it. Skip if error. + i = imtgetim (list, Memc[fname], SZ_PATHNAME) + iferr (im = immap (Memc[fname], READ_ONLY, 0)) { + call erract (EA_WARN) + next + } + if (verbose) { + call printf ("%s ") + call pargstr (Memc[fname]) + call flush (STDOUT) + } + + # Look into image header for columnar info and do the copy. + if (mode == MODE_OUT_ALL || mode == MODE_TEM_ALL) { + iferr (call tm_hc (tp, cp, ncp, rowc, rflag, im)) { + call erract (EA_WARN) + call imunmap (im) + next + } + + # Bump row and image counters. + rowc = rowc + 1 + imc = imc + 1 + + # Just copy into single column. + } else if (mode == MODE_OUT_SINGLE || mode == MODE_TEM_SINGLE) { + iferr (call tm_copy (tp, Memi[cp], rowc, rflag, im)) { + call erract (EA_WARN) + call imunmap (im) + next + } + + # Bump row and image counters. + rowc = rowc + 1 + imc = imc + 1 + } + + if (verbose) { + call printf ("-> %s row=%d \n") + call pargstr (outname) + call pargi (rowc-1) + call flush (STDOUT) + } + + # Close current image. + call imunmap (im) + } + + call imtclose (list) + call sfree (sp) + if (imc == 0) + call error (1, "No images were inserted.") +end diff --git a/pkg/utilities/nttools/threed/tiimage/tmmode.x b/pkg/utilities/nttools/threed/tiimage/tmmode.x new file mode 100644 index 00000000..0f159763 --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/tmmode.x @@ -0,0 +1,108 @@ +include +include "tiimage.h" + +# TM_MODE -- Detect mode of operation. +# +# There are five possible modes: +# 1 - Output table exists and one column was selected. +# 2 - Output table exists and no valid column was selected. +# 3 - Output table does not exist but template exists and one column was +# selected. +# 4 - Output table does not exist but template exists and no valid column +# was selected. +# 5 - New table has to be created from scratch. +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) +# 8-Apr-02 - Remove the call to whatfile (P. Hodge) + + +int procedure tm_mode (output, template, root, rs, cs, cn, cu, cf) + +char output[SZ_PATHNAME] +char template[SZ_PATHNAME] +char root[SZ_FNAME] +char rs[SZ_FNAME] +char cs[SZ_FNAME] +char cn[SZ_COLNAME] +char cu[SZ_COLUNITS] +char cf[SZ_COLFMT] +#- +int mode + +int access(), tm_m1() + +begin + # Process output name. Notice that routine access() must be + # supplied with only the root name in order to succeed. + call rdselect (output, root, rs, cs, SZ_PATHNAME) + if (access (root, READ_WRITE, 0) == YES) { + mode = tm_m1 (OUTPUT_TYPE, root,rs,cs,cn,cu,cf) + if (mode == MODE_ERROR) + call error (1, "Cannot use output file.") + + # If no valid output, try with template name. + } else { + call rdselect (template, root, rs, cs, SZ_PATHNAME) + if (access (root, READ_ONLY, 0) == YES) { + mode = tm_m1 (TEMPLATE_TYPE, root, rs, cs, cn, cu, cf) + if (mode == MODE_ERROR) + call error (1, "Cannot use template file.") + } else { + mode = MODE_SCRATCH + } + } + + return (mode) +end + + +# TM_M1 -- Verify status of file and column selector. + +int procedure tm_m1 (type, root, rs, cs, cn, cu, cf) + +int type +char root[SZ_FNAME] +char rs[SZ_FNAME] +char cs[SZ_FNAME] +char cn[SZ_COLNAME] +char cu[SZ_COLUNITS] +char cf[SZ_COLFMT] +#- +pointer tp, cp +int numcol, ncp + +pointer tbtopn() +int tbpsta() + +begin + # Open table + tp = tbtopn (root, READ_ONLY, 0) + + # Get its total number of columns. + numcol = tbpsta (tp, TBL_NCOLS) + + # Create array of column pointers from column selector. + # This is just to get the actual number of selected columns. + call malloc (cp, numcol, TY_INT) + call tcs_open (tp, cs, Memi[cp], ncp, numcol) + call tbtclo (tp) + call mfree (cp, TY_INT) + + # Decide mode. + if (type == OUTPUT_TYPE) { + if (ncp == 1) + return (MODE_OUT_SINGLE) + else + return (MODE_OUT_ALL) + } else if (type == TEMPLATE_TYPE) { + if (ncp == 1) + return (MODE_TEM_SINGLE) + else + return (MODE_TEM_ALL) + } + return (MODE_ERROR) +end diff --git a/pkg/utilities/nttools/threed/tiimage/tmscan.x b/pkg/utilities/nttools/threed/tiimage/tmscan.x new file mode 100644 index 00000000..31af8c02 --- /dev/null +++ b/pkg/utilities/nttools/threed/tiimage/tmscan.x @@ -0,0 +1,96 @@ +include +include +include + +# TM_SCAN -- Scan input image list and create column pointer array +# and table from information stored in image headers. +# +# +# +# +# Revision history: +# ---------------- +# 30-Jan-97 - Task created (I.Busko) +# 21-May-97 - Changes from code review (IB) + + +procedure tm_scan (otp, ocp, ocpsize, nocp, imlist) + +pointer otp # i: output table pointer +pointer ocp # io: output table column pointer array +int ocpsize # i: size of above array +int nocp # o: actual number of columns in array +char imlist[ARB] # i: input image list +#-- +pointer sp, im, list +pointer imname, cn, cn1, cu, cf, duma +int image, column, lendata, dumi, i +bool match + +errchk tm_header + +pointer imtopen(), immap() +int imtlen(), imtgetim() +bool streq() + +begin + call smark (sp) + call salloc (imname, SZ_PATHNAME, TY_CHAR) + call salloc (cn, SZ_COLNAME, TY_CHAR) + call salloc (cn1, SZ_COLNAME, TY_CHAR) + call salloc (cu, SZ_COLUNITS, TY_CHAR) + call salloc (cf, SZ_COLFMT, TY_CHAR) + call salloc (duma, max(SZ_COLUNITS,SZ_COLFMT),TY_CHAR) + + # Open input list and initialize number of columns. + list = imtopen (imlist) + nocp = 0 + + # Scan input list. + do image = 1, imtlen(list) { + + # Open image. + i = imtgetim (list, Memc[imname], SZ_PATHNAME) + iferr (im = immap (Memc[imname], READ_ONLY, 0)) { + call erract (EA_WARN) + next + } + + # Get column data from image header. + iferr (call tm_header (im, Memc[cn], Memc[cu], Memc[cf])) { + call erract (EA_WARN) + next + } + + # Array size is full image size. + lendata = 1 + do i = 1, IM_NDIM(im) + lendata = lendata * IM_LEN(im,i) + + + # See if column name from header matches any name + # already stored in column pointer array. + match = false + do column = 1, nocp { + call tbcinf (Memi[ocp+column-1], dumi, Memc[cn1], + Memc[duma], Memc[duma], dumi, dumi, dumi) + if (streq (Memc[cn1], Memc[cn])) { + match = true + break + } + } + if (!match) { + + # No names matched, define new column. + call tbcdef (otp, Memi[ocp+nocp], Memc[cn], Memc[cu], + Memc[cf], IM_PIXTYPE(im), lendata, 1) + nocp = nocp + 1 + } + } + + call imtclose (list) + call sfree (sp) + if (nocp == 0) + call error (1, "No images with column data in header.") + call tbtcre (otp) +end diff --git a/pkg/utilities/nttools/threed/titable.par b/pkg/utilities/nttools/threed/titable.par new file mode 100644 index 00000000..41ae759a --- /dev/null +++ b/pkg/utilities/nttools/threed/titable.par @@ -0,0 +1,7 @@ +intable,s,a,"",,,"Input tables" +outtable,s,a,"",,,"Output table" +template,s,h,"",,,"Template table" +row,i,h,INDEF,,,"Begin insertion in row" +verbose,b,h,yes,,,"Print operations performed ?" +version,s,h,"7Feb2000",,, +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/threed/titable/design1.txt b/pkg/utilities/nttools/threed/titable/design1.txt new file mode 100644 index 00000000..a4040192 --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/design1.txt @@ -0,0 +1,224 @@ + + + Design of 3-D table insertion task + ---------------------------------- + + + Author: I. Busko + + + Revision history: + 12/16/96 - First version. + + + + +1. Specifications / requirements: + +This task will perform the inverse operation performed by task txtable. +It will insert (in the tainsert task sense) one or more 2-D tables into +rows of a 3-D table. Alternatively, it will create a 3-D table from the +2-D input tables. Each column in the input 2-D table is inserted as an +array into a single cell at the specified row in the output table. +Additional scalar columns, stored in the headers of the input table by +txtable, will also be processed. + +This design proposes a first, non-sophisticated version of the task. The +emphasis is on simplicity rather than providing support for all possible +situations. For instance, what to do if the size of a given column in one +of the input tables is larger than the corresponding array size in an +existing output table ? Throw away extra elements ? Resize output table ? +But what rules to follow in order to fill back the now resized arrays ? This +design will solve problems like these by resorting to the simplest (from the +code viewpoint) solution (in this case, just ignore the extra elements). + +If the output table does not exist, the first input table in the list +will define both the column information for the output table, as well as +its maximum array size. Columns in the input and output table will be +matched by column name. If a given column in an input table does not exist +in a previously existing output table, it will be ignored. + +The task will be named "titable" following a former proposal for naming +the 3-D table utilities. + + + +2. Language: + +SPP, to allow the use of the generic datatype compiling facility, and to +reuse significant amounts of code already developed for txtable, tximage +and tainsert. + + + +3. Task parameters: + +Name Type What + +input file list/template list of 2D table names with optional + row/column bracket selectors. +output file name 3-D table name with no row/column selectors + (modified in place or created from scratch). +row int row in output table where to begin insertion. + + + +4. Data structures: + +The main data structures are two pointer-type column descriptor arrays, in +the sense defined by the tcs_ routines in the selector library. One array +is associated with the output table, and the other array is associated +with the current input table. + +The output table array is sized to store column information from both the +actual columnar data in the input tables, as well as any scalar data +stored in the input table headers by the txtable task. If the output table +already exists, it will define the array size and contents completely. +If it is being created by the task, the first input table in the list will +define the size and content of the output descriptor array. Thus if other +tables in the input list have additional columns (both physical or in the +form of header-stored scalars), these additional columns will be ignored. + + + +5. Code structure: + +The listing below shows only the most important subroutines; lower-level +functions such as decoding header keywords are not explicited. + +The first section deals with creating the main column descriptor array +for the output table. If the table does not exist, column information +must be read from the input table columns themselves AND from eventual +scalar columns stored in the header by txtable. + +The second section scans the input list and performs the actual insertion +operation. Again, a separate piece of code exists for the cases where a +physical column exists in the input table, or an header-stored scalar +instead. The innermost loop takes care of reading only the selected rows +from the input table. + +- Read task parameters (clget). +- Alloc work memory (malloc, calloc). +- Strip output name from eventual bracket selectors (rdselect). +- Open input list (imtopen). +- If output table already exists (access). + **> Procedure TIUPDATE: + - Open output table (tbtopn). + - Create array of column pointers from output table (malloc, tcs_open). + **> End TIUPDATE. +- Else + **> Procedure TINEW: + - Get first table name from input list (imtgetim). + - Check if it is a table (whatfile). Exit if not. + - Break name into bracketed selectors (rdselect). + - Open input table (tbtopn). + - Get its total (selected and unselected) number of rows (tbpsta). + + - Scalars in input table are signaled by TCTOTAL keyword in input table + header. Look for it (tbhfkr) and increase number of output columns by + the value of TCTOTAL. + + - Create array of column pointers from input column selector and TCTOTAL + info (malloc, tcs_open). + - If no columns were matched, and no TCTOTAL keyword was found, exit. + - Open output table (no STDOUT allowed) (tbtopn). + **> Procedure TISETC: + - Loop over input column pointer array, if it exists. + - Copy column information from input to output (tbcinf, tbcdef), + setting the output array size to be the input number of rows. + - End loop. + - Loop over all possible keyword sets (from 1 to TCTOTAL). + - Look for TCD_xxx keyword (tbhfkr). + - If found: + - Decode TCD keyword into column data (name, datatype, format) + - Create scalar column in output table's column array (tbcdef). + - End if. + - End loop. + **> End TISETC: + - Create output table (tbtcre). + - Close input table (tbtclo). + - Rewind input list (imtrew). + **> End TINEW: +- End if. +- Initialize row counter with "row" parameter value (clgeti). Set flag if row + parameter is negative or INDEF. +**> Procedure TINSERT: + - Loop over input list (imtlen). + - Get table name (imtgetim). + - Check if it is a table (whatfile). Skip and warn user if not. + - Break name into bracketed selectors (rdselect). + - Open input table (tbtopn). + - Look for ORIG_ROW keyword (tbhfkr). If found, and if "row" parameter + is negative or INDEF, supersede row counter with keyword value. + - Find how many rows were requested by row selector (trsopen, trseval, + trsclose). + - Create array of column pointers from column selector. If no columns + were matched, exit (malloc, tcs_open). + **> Procedure TICOPY: + - Loop over output table column pointers. + - Get column info from output table (tcs_column, tbcinf) + - loop over input table column pointers. + - Get column info from input table (tcs_column, tbcinf) + - If column names match: + **> Procedure TICC: + - Get output array size (tcs_totsize). + - Choose the minimum in between this array size and the + number of rows selected from input table. If less rows + than array elements, warn user. + - Get data types of both input and output columns + (tcs_intinfo). + If character-type, get string size too. + **> Procedure TIROWS (generic data type): + - Alloc buffer of appropriate type and with size + given by the minimum size computed above (malloc). + - Copy selected rows from input table into buffer + (trsopen, trseval, tbcgt, trsclose). + - Copy buffer into designated row/column (tbapt). + - If output exists and array is larger than buffer: + - Set remaining elements to INDEF. + - End if. + - Free buffer (mfree). + **> End TIROWS. + **> End TICC. + - Else (no match), look for scalar data in input header: + **> Procedure TIHC: + - Look for TCTOTAL keyword (tbhfkr). If found: + - Loop over all possible keyword sets (from 1 to + TCTOTAL). + - Look for TCD_xxx keyword (tbhfkr). + - Decode TCD keyword to extract column name. + - If column name from header matches with output + column name: + - Look for TCV_xxx keyword (tbhfkr). If found: + **> Procedure TIWRSC (generic data type): + - Write scalar data (tbcpt). + **> End TIWRSC. + - Else + - Warn user that input table header is + corrupted. + - End if. + - End if. + - End loop. + - End if. + **> End TIHC. + - End if. + - End loop. + - End loop. + **> End TICOPY. + - Free input table's array of column pointers (tcs_close, mfree). + - Close input table (tbtclo). + - Bump output row counter. + - End loop. +**> End TINSERT: +- Free output table's array of column pointers (tcs_close, mfree). +- Close output table (tbtclo). +- Close input list (imtclose). +- Free work memory (mfree). + + + + + + + + diff --git a/pkg/utilities/nttools/threed/titable/design2.txt b/pkg/utilities/nttools/threed/titable/design2.txt new file mode 100644 index 00000000..99ceb57f --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/design2.txt @@ -0,0 +1,244 @@ + + + Design of 3-D table insertion task + ---------------------------------- + + + Author: I. Busko + + + Revision history: + 12/16/96 - First version. + 01/15/97 - Revised after design review. + 01/20/97 - Matches version 1.0 of code. + + Revision content: + 01/20/97: (i) internal flow control of TICOPY routine; (ii) the two main + data structures now store "regular" column pointers (in the + tbtable sense) instead of column pointers in the tcs_ sense; + (iii) inclusion of a template table. + + + +1. Specifications / requirements: + +This task will perform the inverse operation performed by task txtable. +It will insert (in the tainsert task sense) one or more 2-D tables into +rows of a 3-D table. Alternatively, it will create a 3-D table from the +2-D input tables. Each column in the input 2-D table is inserted as an +array into a single cell at the specified row in the output table. +Additional scalar columns, stored in the headers of the input table by +txtable, will also be processed. Row/column selectors in the input table +names will be supported. + +This design proposes a first, non-sophisticated version of the task. The +emphasis is on simplicity rather than providing support for all possible +situations. For instance, what to do if the size of a given column in one +of the input tables is larger than the corresponding array size in an +existing output table ? Throw away the extra elements ? Resize output table ? +But what rules to follow in order to fill back the now resized arrays ? This +design will solve problems like these by resorting to the simplest (from the +code viewpoint) solution (in this case, just ignore the extra elements). + +If the output table does not exist, the first input table in the list +will define both the column information for the output table, as well as +its maximum array size. Columns in the input and output table will be +matched by column name. If a given column in an input table does not exist +in a previously existing output table, it will be ignored. + +From design review: an existing table can be used as a template when creating +a new 3-D output table. If no template is supplied, the first table in the +input list becomes the template. + +Because the selector mechanism does not work with scalars stored in the +input tables' headers by task txtable, these scalars, if existent, will +be always inserted in the output table, provided column names match. + +An error results when: +- an array is found in a cell in any of the input tables, +- datatypes in input and output columns do not agree. + +The task will be named "titable" following a former proposal for naming +the 3-D table utilities. + + + +2. Language: + +SPP, to allow the use of the generic datatype compiling facility, and to +reuse significant amounts of code already developed for txtable, tximage +and tainsert. + + + +3. Task parameters: + +Name Type What + +input file list/template list of 2D table names with optional + row/column bracket selectors. +output file name 3-D table name with no row/column selectors + (modified in place or created from scratch). +template file name 3-D template table with column selectors +row int row in output table where to begin insertion. + + + +4. Data structures: + +The main data structures are two pointer-type column descriptor arrays. +One array is associated with the output table, and the other array is +associated with the current input table. + +The output table array is sized to store column information from both the +actual columnar data in the input tables, as well as any scalar data +stored in the input table headers by the txtable task. If the output table +already exists, it will define the array size and contents completely. +If it is being created by the task, the first input table in the list will +define the size and content of the output descriptor array. Thus if other +tables in the input list have additional columns (both physical or in the +form of header-stored scalars), these additional columns will be ignored. + + + +5. Code structure: + +The listing below shows only the most important subroutines; lower-level +functions such as decoding header keywords are not explicited. + +The first section deals with creating the main column descriptor array +for the output table. If the table does not exist, column information +must be read from the input table columns themselves AND from eventual +scalar columns stored in the header by txtable. + +The second section scans the input list and performs the actual insertion +operation. Again, a separate piece of code exists for the cases where a +physical column exists in the input table, or an header-stored scalar +instead. The innermost loop takes care of reading only the selected rows +from the input table. + +- Read task parameters (clget). +- Alloc work memory (malloc, calloc). +- Strip output name from eventual bracket selectors (rdselect). +- Open input list (imtopen). +- If output table already exists (access). + **> Procedure TIUPDATE: + - Open output table (tbtopn). + - Create array of column pointers from output table (malloc, tcs_open). + - Get column pointers from tcs structure. + **> End TIUPDATE. +- Else + **> Procedure TINEW: + - If template table is not valid: + - Get first table name from input list (imtgetim). + - End if. + - Check if it is a table (whatfile). Exit if not. + - Break name into bracketed selectors (rdselect). + - Open template table (tbtopn). + - Get its total (selected and unselected) number of rows (tbpsta). + - Scalars in input table are signaled by TCTOTAL keyword in input table + header. Look for it (tbhfkr) and increase number of output columns. + - Create array of column pointers from input column selector and TCTOTAL + info (malloc, tcs_open). + - If no columns were matched, and no TCTOTAL keyword was found, exit. + - Open output table (no STDOUT allowed) (tbtopn). + **> Procedure TISETC: + - Loop over input column pointer array, if it exists. + - Copy column information from input to output (tbcinf, tbcdef), + setting the output array size to be the input number of rows + in the case of a 2-D template, or keeping it the same size + in the case of a 3-D template. + - End loop. + - Loop over all possible keyword sets (from 1 to TCTOTAL). + - Look for TCD_xxx keyword (tbhfkr). + - If found: + - Decode TCD keyword into column data (name, datatype, format) + - Create scalar column in output table's column array (tbcdef). + - End if. + - End loop. + **> End TISETC: + - Create output table (tbtcre). + - Close input table (tbtclo). + - Rewind input list (imtrew). + **> End TINEW: +- End if. +- Initialize row counter with "row" parameter value (clgeti). Set flag if row + parameter is negative or INDEF. +**> Procedure TINSERT: + - Loop over input list (imtlen). + - Get table name (imtgetim). + - Check if it is a table (whatfile). Skip and warn user if not. + - Break name into bracketed selectors (rdselect). + - Open input table (tbtopn). + - Look for ORIG_ROW keyword (tbhfkr). If found, and if "row" parameter + is negative or INDEF, supersede row counter with keyword value. + - Find how many rows were requested by row selector (trsopen, trseval, + trsclose). + - Create array of column pointers from column selector (malloc,tcs_open). + **> Procedure TICOPY: + - Loop over output table column pointers. + - Get column info from output table (tbcinf) + - Choose the minimum in between this array size and the number + of rows selected from input table (tbalen). + - If there are matched columns, loop over input table column + pointers. + - Get column info from input table (tcs_column, tbcinf) + - If column names match: + - If data types do not match, abort. + **> Procedure TICC: + - If character-type, get string size. + given by the minimum size computed above (malloc). + **> Procedure TIROWS (generic data type): + - Alloc buffer of appropriate type and with size + - Copy selected rows from input table into buffer + (trsopen, trseval, tbcgt, trsclose). + - Copy buffer into designated row/column (tbapt). + - If output exists and array is larger than buffer: + - Set remaining elements to INDEF. + - End if. + **> End TIROWS. + **> End TICC. + - Else (no match), look for scalar data in input header: + - Look for TCTOTAL keyword (tbhfkr). If found: + - Loop over all possible keyword sets (from 1 to + TCTOTAL). + - Look for TCD_xxx keyword (tbhfkr). + - Decode TCD keyword to extract column name. + - If column name from header matches with output + column name: + **> Procedure TICH (generic datatype): + - Look for TCV_xxx keyword (tbhfkr). If found: + - Read value. + - Write scalar data (tbcpt). + - Else + - Warn user that input table header is + corrupted. + - End if. + **> End TICH. + - End if. + - End loop. + - End if. + - End if (Notice that a no-match case, both from columns and + header scalars, is not an error since the output or + template table may have columns that do not exist + among the selected columns in the input table). + - End loop. + - End loop. + **> End TICOPY. + - Free input table's array of column pointers (tcs_close, mfree). + - Close input table (tbtclo). + - Bump output row counter. + - End loop. +**> End TINSERT: +- Free output table's array of column pointers (tcs_close, mfree). +- Close output table (tbtclo). +- Close input list (imtclose). +- Free work memory (mfree). + + + + + + + + diff --git a/pkg/utilities/nttools/threed/titable/generic/mkpkg b/pkg/utilities/nttools/threed/titable/generic/mkpkg new file mode 100644 index 00000000..f65f2f1c --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/generic/mkpkg @@ -0,0 +1,22 @@ +# Update the generic routines. + +default: + $checkout libpkg.a ../../ + $update libpkg.a + $checkin libpkg.a ../../ +$exit + +libpkg.a: + tirowsb.x + tirowsc.x + tirowsd.x + tirowsi.x + tirowsr.x + tirowss.x + tichb.x + tichc.x + tichd.x + tichi.x + tichr.x + tichs.x + ; diff --git a/pkg/utilities/nttools/threed/titable/generic/tichb.x b/pkg/utilities/nttools/threed/titable/generic/tichb.x new file mode 100644 index 00000000..895c6aab --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/generic/tichb.x @@ -0,0 +1,52 @@ +include + +# TICH -- Copy data from input header into scalar cell in output. +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) + + +procedure tichb (itp, ihc, otp, ocp, orow) + +pointer itp # i: input table descriptor +int ihc # i: header keyword index +pointer otp # i: output table descriptor +pointer ocp # i: output column descriptor +int orow # i: row where to insert +#-- +bool buf +pointer sp, kwname, kwval +int datatype, parnum + +string corrupt "Corrupted header in input table." + +int nscan() + +begin + call smark (sp) + call salloc (kwname, SZ_LINE, TY_CHAR) + call salloc (kwval, SZ_PARREC, TY_CHAR) + + # Build keyword name and look for it. + call sprintf (Memc[kwname], SZ_LINE, "TCV_%03d") + call pargi (ihc) + call tbhfkr (itp, Memc[kwname], datatype, Memc[kwval], parnum) + + # Parse and read value. We assume that the keyword existence + # was confirmed by previously finding the paired TCD_ keyword. + if (parnum > 0) { + call sscan (Memc[kwval]) + call gargb (buf) + if (nscan() < 1) call error (1, corrupt) + } else + call error (1, corrupt) + + # Write value into scalar cell. + call tbcptb (otp, ocp, buf, orow, orow) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/threed/titable/generic/tichc.x b/pkg/utilities/nttools/threed/titable/generic/tichc.x new file mode 100644 index 00000000..0685918e --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/generic/tichc.x @@ -0,0 +1,54 @@ +include + +# TICH -- Copy data from input header into scalar cell in output. +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) + + +procedure ticht (itp, ihc, otp, ocp, orow, maxch) + +pointer itp # i: input table descriptor +int ihc # i: header keyword index +pointer otp # i: output table descriptor +pointer ocp # i: output column descriptor +int orow # i: row where to insert +int maxch +#-- +pointer buf +pointer sp, kwname, kwval +int datatype, parnum + +string corrupt "Corrupted header in input table." + +int nscan() + +begin + call smark (sp) + call salloc (buf, maxch + 1, TY_CHAR) + call salloc (kwname, SZ_LINE, TY_CHAR) + call salloc (kwval, SZ_PARREC, TY_CHAR) + + # Build keyword name and look for it. + call sprintf (Memc[kwname], SZ_LINE, "TCV_%03d") + call pargi (ihc) + call tbhfkr (itp, Memc[kwname], datatype, Memc[kwval], parnum) + + # Parse and read value. We assume that the keyword existence + # was confirmed by previously finding the paired TCD_ keyword. + if (parnum > 0) { + call sscan (Memc[kwval]) + call gargwrd (buf, maxch) + if (nscan() < 1) call error (1, corrupt) + } else + call error (1, corrupt) + + # Write value into scalar cell. + call tbcptt (otp, ocp, buf, maxch, orow, orow) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/threed/titable/generic/tichd.x b/pkg/utilities/nttools/threed/titable/generic/tichd.x new file mode 100644 index 00000000..331b9813 --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/generic/tichd.x @@ -0,0 +1,52 @@ +include + +# TICH -- Copy data from input header into scalar cell in output. +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) + + +procedure tichd (itp, ihc, otp, ocp, orow) + +pointer itp # i: input table descriptor +int ihc # i: header keyword index +pointer otp # i: output table descriptor +pointer ocp # i: output column descriptor +int orow # i: row where to insert +#-- +double buf +pointer sp, kwname, kwval +int datatype, parnum + +string corrupt "Corrupted header in input table." + +int nscan() + +begin + call smark (sp) + call salloc (kwname, SZ_LINE, TY_CHAR) + call salloc (kwval, SZ_PARREC, TY_CHAR) + + # Build keyword name and look for it. + call sprintf (Memc[kwname], SZ_LINE, "TCV_%03d") + call pargi (ihc) + call tbhfkr (itp, Memc[kwname], datatype, Memc[kwval], parnum) + + # Parse and read value. We assume that the keyword existence + # was confirmed by previously finding the paired TCD_ keyword. + if (parnum > 0) { + call sscan (Memc[kwval]) + call gargd (buf) + if (nscan() < 1) call error (1, corrupt) + } else + call error (1, corrupt) + + # Write value into scalar cell. + call tbcptd (otp, ocp, buf, orow, orow) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/threed/titable/generic/tichi.x b/pkg/utilities/nttools/threed/titable/generic/tichi.x new file mode 100644 index 00000000..fe01a4ac --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/generic/tichi.x @@ -0,0 +1,52 @@ +include + +# TICH -- Copy data from input header into scalar cell in output. +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) + + +procedure tichi (itp, ihc, otp, ocp, orow) + +pointer itp # i: input table descriptor +int ihc # i: header keyword index +pointer otp # i: output table descriptor +pointer ocp # i: output column descriptor +int orow # i: row where to insert +#-- +int buf +pointer sp, kwname, kwval +int datatype, parnum + +string corrupt "Corrupted header in input table." + +int nscan() + +begin + call smark (sp) + call salloc (kwname, SZ_LINE, TY_CHAR) + call salloc (kwval, SZ_PARREC, TY_CHAR) + + # Build keyword name and look for it. + call sprintf (Memc[kwname], SZ_LINE, "TCV_%03d") + call pargi (ihc) + call tbhfkr (itp, Memc[kwname], datatype, Memc[kwval], parnum) + + # Parse and read value. We assume that the keyword existence + # was confirmed by previously finding the paired TCD_ keyword. + if (parnum > 0) { + call sscan (Memc[kwval]) + call gargi (buf) + if (nscan() < 1) call error (1, corrupt) + } else + call error (1, corrupt) + + # Write value into scalar cell. + call tbcpti (otp, ocp, buf, orow, orow) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/threed/titable/generic/tichr.x b/pkg/utilities/nttools/threed/titable/generic/tichr.x new file mode 100644 index 00000000..b81dd97b --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/generic/tichr.x @@ -0,0 +1,52 @@ +include + +# TICH -- Copy data from input header into scalar cell in output. +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) + + +procedure tichr (itp, ihc, otp, ocp, orow) + +pointer itp # i: input table descriptor +int ihc # i: header keyword index +pointer otp # i: output table descriptor +pointer ocp # i: output column descriptor +int orow # i: row where to insert +#-- +real buf +pointer sp, kwname, kwval +int datatype, parnum + +string corrupt "Corrupted header in input table." + +int nscan() + +begin + call smark (sp) + call salloc (kwname, SZ_LINE, TY_CHAR) + call salloc (kwval, SZ_PARREC, TY_CHAR) + + # Build keyword name and look for it. + call sprintf (Memc[kwname], SZ_LINE, "TCV_%03d") + call pargi (ihc) + call tbhfkr (itp, Memc[kwname], datatype, Memc[kwval], parnum) + + # Parse and read value. We assume that the keyword existence + # was confirmed by previously finding the paired TCD_ keyword. + if (parnum > 0) { + call sscan (Memc[kwval]) + call gargr (buf) + if (nscan() < 1) call error (1, corrupt) + } else + call error (1, corrupt) + + # Write value into scalar cell. + call tbcptr (otp, ocp, buf, orow, orow) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/threed/titable/generic/tichs.x b/pkg/utilities/nttools/threed/titable/generic/tichs.x new file mode 100644 index 00000000..5dbce604 --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/generic/tichs.x @@ -0,0 +1,52 @@ +include + +# TICH -- Copy data from input header into scalar cell in output. +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) + + +procedure tichs (itp, ihc, otp, ocp, orow) + +pointer itp # i: input table descriptor +int ihc # i: header keyword index +pointer otp # i: output table descriptor +pointer ocp # i: output column descriptor +int orow # i: row where to insert +#-- +short buf +pointer sp, kwname, kwval +int datatype, parnum + +string corrupt "Corrupted header in input table." + +int nscan() + +begin + call smark (sp) + call salloc (kwname, SZ_LINE, TY_CHAR) + call salloc (kwval, SZ_PARREC, TY_CHAR) + + # Build keyword name and look for it. + call sprintf (Memc[kwname], SZ_LINE, "TCV_%03d") + call pargi (ihc) + call tbhfkr (itp, Memc[kwname], datatype, Memc[kwval], parnum) + + # Parse and read value. We assume that the keyword existence + # was confirmed by previously finding the paired TCD_ keyword. + if (parnum > 0) { + call sscan (Memc[kwval]) + call gargs (buf) + if (nscan() < 1) call error (1, corrupt) + } else + call error (1, corrupt) + + # Write value into scalar cell. + call tbcpts (otp, ocp, buf, orow, orow) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/threed/titable/generic/tirowsb.x b/pkg/utilities/nttools/threed/titable/generic/tirowsb.x new file mode 100644 index 00000000..f87a0861 --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/generic/tirowsb.x @@ -0,0 +1,71 @@ +include + +# +# TIROWS -- Expand row selector into array and copy it into output +# table cell. +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-1997 - Task created (I.Busko) +# 7-Feb-2000 - For datatype = 'c', make buf an array of strings (P.Hodge) + + +procedure tirowsb (itp, icp, otp, ocp, rowsel, orow, len, buf) + +pointer itp # i: input table descriptor +pointer icp # i: input column descriptor +pointer otp # i: output table descriptor +pointer ocp # i: output column descriptor +char rowsel[ARB] # i: row selector +int orow # i: row in output table where to write into +int len # i: buffer length +bool buf[ARB] +#-- +double undefd +real undefr +pointer pcode +int undefi, i, nelem, irow, numrow, alength +short undefs + +pointer trsopen() +int tbpsta(), tbalen() +bool trseval() + +begin + # Loop over selected rows on input table. + pcode = trsopen (itp, rowsel) + numrow = tbpsta (itp, TBL_NROWS) + nelem = 0 + do irow = 1, numrow { + if (trseval (itp, irow, pcode)) { + nelem = nelem + 1 + if (nelem > len) { + nelem = len + break + } + # Get element and store in buffer. + call tbegtb (itp, icp, irow, buf[nelem]) + } + } + call trsclose (pcode) + + # Write buffer into array cell element. + call tbaptb (otp, ocp, orow, buf, 1, nelem) + + # If number of selected rows in current input table + # is smaller than output table array length, fill + # remaining array elements with INDEF. + alength = tbalen (ocp) + if (alength > nelem) { + undefd = INDEFD + undefr = INDEFR + undefi = INDEFI + undefs = INDEFS + do i = nelem+1, alength { + call tbaptb (otp, ocp, orow, false, i, 1) + } + } +end diff --git a/pkg/utilities/nttools/threed/titable/generic/tirowsc.x b/pkg/utilities/nttools/threed/titable/generic/tirowsc.x new file mode 100644 index 00000000..01d11000 --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/generic/tirowsc.x @@ -0,0 +1,72 @@ +include + +# +# TIROWS -- Expand row selector into array and copy it into output +# table cell. +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-1997 - Task created (I.Busko) +# 7-Feb-2000 - For datatype = 'c', make buf an array of strings (P.Hodge) + + +procedure tirowst (itp, icp, otp, ocp, rowsel, orow, maxch, len, buf) + +pointer itp # i: input table descriptor +pointer icp # i: input column descriptor +pointer otp # i: output table descriptor +pointer ocp # i: output column descriptor +char rowsel[ARB] # i: row selector +int orow # i: row in output table where to write into +int maxch # i: max length of string +int len # i: buffer length +char buf[maxch,ARB] # i: work buffer +#-- +double undefd +real undefr +pointer pcode +int undefi, i, nelem, irow, numrow, alength +short undefs + +pointer trsopen() +int tbpsta(), tbalen() +bool trseval() + +begin + # Loop over selected rows on input table. + pcode = trsopen (itp, rowsel) + numrow = tbpsta (itp, TBL_NROWS) + nelem = 0 + do irow = 1, numrow { + if (trseval (itp, irow, pcode)) { + nelem = nelem + 1 + if (nelem > len) { + nelem = len + break + } + # Get element and store in buffer. + call tbegtt (itp, icp, irow, buf[1,nelem], maxch) + } + } + call trsclose (pcode) + + # Write buffer into array cell element. + call tbaptt (otp, ocp, orow, buf, maxch, 1, nelem) + + # If number of selected rows in current input table + # is smaller than output table array length, fill + # remaining array elements with INDEF. + alength = tbalen (ocp) + if (alength > nelem) { + undefd = INDEFD + undefr = INDEFR + undefi = INDEFI + undefs = INDEFS + do i = nelem+1, alength { + call tbaptt (otp, ocp, orow, "", maxch, i, 1) + } + } +end diff --git a/pkg/utilities/nttools/threed/titable/generic/tirowsd.x b/pkg/utilities/nttools/threed/titable/generic/tirowsd.x new file mode 100644 index 00000000..3af5468c --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/generic/tirowsd.x @@ -0,0 +1,71 @@ +include + +# +# TIROWS -- Expand row selector into array and copy it into output +# table cell. +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-1997 - Task created (I.Busko) +# 7-Feb-2000 - For datatype = 'c', make buf an array of strings (P.Hodge) + + +procedure tirowsd (itp, icp, otp, ocp, rowsel, orow, len, buf) + +pointer itp # i: input table descriptor +pointer icp # i: input column descriptor +pointer otp # i: output table descriptor +pointer ocp # i: output column descriptor +char rowsel[ARB] # i: row selector +int orow # i: row in output table where to write into +int len # i: buffer length +double buf[ARB] +#-- +double undefd +real undefr +pointer pcode +int undefi, i, nelem, irow, numrow, alength +short undefs + +pointer trsopen() +int tbpsta(), tbalen() +bool trseval() + +begin + # Loop over selected rows on input table. + pcode = trsopen (itp, rowsel) + numrow = tbpsta (itp, TBL_NROWS) + nelem = 0 + do irow = 1, numrow { + if (trseval (itp, irow, pcode)) { + nelem = nelem + 1 + if (nelem > len) { + nelem = len + break + } + # Get element and store in buffer. + call tbegtd (itp, icp, irow, buf[nelem]) + } + } + call trsclose (pcode) + + # Write buffer into array cell element. + call tbaptd (otp, ocp, orow, buf, 1, nelem) + + # If number of selected rows in current input table + # is smaller than output table array length, fill + # remaining array elements with INDEF. + alength = tbalen (ocp) + if (alength > nelem) { + undefd = INDEFD + undefr = INDEFR + undefi = INDEFI + undefs = INDEFS + do i = nelem+1, alength { + call tbaptd (otp, ocp, orow, undefd, i, 1) + } + } +end diff --git a/pkg/utilities/nttools/threed/titable/generic/tirowsi.x b/pkg/utilities/nttools/threed/titable/generic/tirowsi.x new file mode 100644 index 00000000..6cf4b069 --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/generic/tirowsi.x @@ -0,0 +1,71 @@ +include + +# +# TIROWS -- Expand row selector into array and copy it into output +# table cell. +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-1997 - Task created (I.Busko) +# 7-Feb-2000 - For datatype = 'c', make buf an array of strings (P.Hodge) + + +procedure tirowsi (itp, icp, otp, ocp, rowsel, orow, len, buf) + +pointer itp # i: input table descriptor +pointer icp # i: input column descriptor +pointer otp # i: output table descriptor +pointer ocp # i: output column descriptor +char rowsel[ARB] # i: row selector +int orow # i: row in output table where to write into +int len # i: buffer length +int buf[ARB] +#-- +double undefd +real undefr +pointer pcode +int undefi, i, nelem, irow, numrow, alength +short undefs + +pointer trsopen() +int tbpsta(), tbalen() +bool trseval() + +begin + # Loop over selected rows on input table. + pcode = trsopen (itp, rowsel) + numrow = tbpsta (itp, TBL_NROWS) + nelem = 0 + do irow = 1, numrow { + if (trseval (itp, irow, pcode)) { + nelem = nelem + 1 + if (nelem > len) { + nelem = len + break + } + # Get element and store in buffer. + call tbegti (itp, icp, irow, buf[nelem]) + } + } + call trsclose (pcode) + + # Write buffer into array cell element. + call tbapti (otp, ocp, orow, buf, 1, nelem) + + # If number of selected rows in current input table + # is smaller than output table array length, fill + # remaining array elements with INDEF. + alength = tbalen (ocp) + if (alength > nelem) { + undefd = INDEFD + undefr = INDEFR + undefi = INDEFI + undefs = INDEFS + do i = nelem+1, alength { + call tbapti (otp, ocp, orow, undefi, i, 1) + } + } +end diff --git a/pkg/utilities/nttools/threed/titable/generic/tirowsr.x b/pkg/utilities/nttools/threed/titable/generic/tirowsr.x new file mode 100644 index 00000000..c6754eaf --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/generic/tirowsr.x @@ -0,0 +1,71 @@ +include + +# +# TIROWS -- Expand row selector into array and copy it into output +# table cell. +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-1997 - Task created (I.Busko) +# 7-Feb-2000 - For datatype = 'c', make buf an array of strings (P.Hodge) + + +procedure tirowsr (itp, icp, otp, ocp, rowsel, orow, len, buf) + +pointer itp # i: input table descriptor +pointer icp # i: input column descriptor +pointer otp # i: output table descriptor +pointer ocp # i: output column descriptor +char rowsel[ARB] # i: row selector +int orow # i: row in output table where to write into +int len # i: buffer length +real buf[ARB] +#-- +double undefd +real undefr +pointer pcode +int undefi, i, nelem, irow, numrow, alength +short undefs + +pointer trsopen() +int tbpsta(), tbalen() +bool trseval() + +begin + # Loop over selected rows on input table. + pcode = trsopen (itp, rowsel) + numrow = tbpsta (itp, TBL_NROWS) + nelem = 0 + do irow = 1, numrow { + if (trseval (itp, irow, pcode)) { + nelem = nelem + 1 + if (nelem > len) { + nelem = len + break + } + # Get element and store in buffer. + call tbegtr (itp, icp, irow, buf[nelem]) + } + } + call trsclose (pcode) + + # Write buffer into array cell element. + call tbaptr (otp, ocp, orow, buf, 1, nelem) + + # If number of selected rows in current input table + # is smaller than output table array length, fill + # remaining array elements with INDEF. + alength = tbalen (ocp) + if (alength > nelem) { + undefd = INDEFD + undefr = INDEFR + undefi = INDEFI + undefs = INDEFS + do i = nelem+1, alength { + call tbaptr (otp, ocp, orow, undefr, i, 1) + } + } +end diff --git a/pkg/utilities/nttools/threed/titable/generic/tirowss.x b/pkg/utilities/nttools/threed/titable/generic/tirowss.x new file mode 100644 index 00000000..91c678c3 --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/generic/tirowss.x @@ -0,0 +1,71 @@ +include + +# +# TIROWS -- Expand row selector into array and copy it into output +# table cell. +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-1997 - Task created (I.Busko) +# 7-Feb-2000 - For datatype = 'c', make buf an array of strings (P.Hodge) + + +procedure tirowss (itp, icp, otp, ocp, rowsel, orow, len, buf) + +pointer itp # i: input table descriptor +pointer icp # i: input column descriptor +pointer otp # i: output table descriptor +pointer ocp # i: output column descriptor +char rowsel[ARB] # i: row selector +int orow # i: row in output table where to write into +int len # i: buffer length +short buf[ARB] +#-- +double undefd +real undefr +pointer pcode +int undefi, i, nelem, irow, numrow, alength +short undefs + +pointer trsopen() +int tbpsta(), tbalen() +bool trseval() + +begin + # Loop over selected rows on input table. + pcode = trsopen (itp, rowsel) + numrow = tbpsta (itp, TBL_NROWS) + nelem = 0 + do irow = 1, numrow { + if (trseval (itp, irow, pcode)) { + nelem = nelem + 1 + if (nelem > len) { + nelem = len + break + } + # Get element and store in buffer. + call tbegts (itp, icp, irow, buf[nelem]) + } + } + call trsclose (pcode) + + # Write buffer into array cell element. + call tbapts (otp, ocp, orow, buf, 1, nelem) + + # If number of selected rows in current input table + # is smaller than output table array length, fill + # remaining array elements with INDEF. + alength = tbalen (ocp) + if (alength > nelem) { + undefd = INDEFD + undefr = INDEFR + undefi = INDEFI + undefs = INDEFS + do i = nelem+1, alength { + call tbapts (otp, ocp, orow, undefs, i, 1) + } + } +end diff --git a/pkg/utilities/nttools/threed/titable/help.txt b/pkg/utilities/nttools/threed/titable/help.txt new file mode 100644 index 00000000..77289bc5 --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/help.txt @@ -0,0 +1,117 @@ +TITABLE (Jan97) threed TITABLE (Jan97) + + + +NAME + titable -- Inserts 2-D tables into rows of a 3-D table. + + +USAGE + titable intable outtable + + +DESCRIPTION + This task performs the inverse operation of task txtable: it + inserts one or more 2-D tables into rows of a 3-D table The input + may be a filename template, including wildcard characters, or the + name of a file (preceded by an @ sign) containing table names. The + output is a single 3-D table name. If the output table exists, + insertion will be done in place. If the output table does not + exist, it will be created. The input and output tables must not be + the same. + + This task supports row/column selectors in the input table names. + These may be used to select subsets of both rows and columns from + the input table. If no selectors are used, all columns and rows + will be processed, Type 'help selectors' to see a description of + the selector syntax. + + When creating a new output table, the information describing its + columns can be taken from two sources. If parameter 'template' has + the name of an existing 3-D table, the column descriptions, + including maximum array sizes, will be taken from that table. If + 'template' has an invalid or null ("") value, the column-defining + information will be take from the first table in the input list, + where its number of rows will define the maximum array size allowed + in the table being created. Column selectors are allowed in the + template table. + + NOTE: Both the output and template table names must always be + supplied complete, including their extension. Otherwise the task + may get confused on the existence of an already existing table. + + Insertion is performed by first verifying if column names in both + input and output tables match. If a match is found, values taken + from that column and all selected rows from the input table will be + stored as a 1-dimensional array in a single cell in the + corresponding column in the output 3-D table. The row in this + table where the insertion takes place is selected by the "row" task + parameter. It points to the row where the first table in the input + list will be inserted, subsequent tables in the list will be + inserted into subsequent rows. This mechanism is superseded if the + "row" parameter is set to INDEF or a negative value, and the + keyword "ORIG_ROW" is found in the header of the input table. This + keyword is created by task txtable and its value supersedes the row + counter in the task. + If the maximum array size in a target column in the output 3-D + table is larger than the number of selected input rows, the array + will be filled up starting from its first element, and the empty + elements at the end will be set to INDEF (or "" if it is a + character string column). If the maximum array size is smaller than + the number of selected rows, insertion begins by the first selected + row up to the maximum allowable size, the remaining rows being + ignored. + + This task correctly handles scalars stored in the input table header + by task txtable. Since the selector mechanism does not work with + these scalars, the task will always insert them into the output + table, provided there is a match in column names. + + +PARAMETERS + + intable [file name list/template] + A list of one or more tables to be inserted. Row/column + selectors are supported. + + outtable [table name] + Name of 3-D output table, including extension. No support + exists for "STDOUT" (ASCII output). + + (template = "") [table name] + Name of 3-D table to be used as template when creating a new + output table. + + (row = INDEF) [int] + Row where insertion begins. If set to INDEF or a negative + value, the row number will be looked for in the input table + header. + + (verbose = yes) [boolean] + Display names of input and output tables as files are processed + ? + + +EXAMPLES + Insert columns named FLUX and WAVELENGTH from input tables into a + 3-D table: + + cl> titable itable*.tab[c:FLUX,WAVELENGTH] otable.tab + + + +BUGS + The output and template table names must be supplied in full, + including the extension (e.g. ".tab"). If the output table name is + not typed in full, the task will create a new table in place of the + existing one, with only the rows actually inserted. This behavior + relates to the way the underlying "access" routine in IRAF's fio + library works. + + +REFERENCES + This task was written by I. Busko. + + +SEE ALSO + txtable, selectors diff --git a/pkg/utilities/nttools/threed/titable/list.tex b/pkg/utilities/nttools/threed/titable/list.tex new file mode 100644 index 00000000..4b78ed5d --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/list.tex @@ -0,0 +1,979 @@ +\documentstyle{article} +\topmargin -30mm +\textheight 250mm +\oddsidemargin -5mm +\evensidemargin -5mm +\textwidth 170mm + +\begin{document} + +\tableofcontents + +\newpage + +\addcontentsline{toc}{section}{help.txt} +\begin{verbatim} + +TITABLE (Jan97) threed TITABLE (Jan97) + + + +NAME + titable -- Inserts 2-D tables into rows of a 3-D table. + + +USAGE + titable intable outtable + + +DESCRIPTION + This task performs the inverse operation of task txtable: it + inserts one or more 2-D tables into rows of a 3-D table The input + may be a filename template, including wildcard characters, or the + name of a file (preceded by an @ sign) containing table names. The + output is a single 3-D table name. If the output table exists, + insertion will be done in place. If the output table does not + exist, it will be created. The input and output tables must not be + the same. + + This task supports row/column selectors in the input table names. + These may be used to select subsets of both rows and columns from + the input table. If no selectors are used, all columns and rows + will be processed, Type 'help selectors' to see a description of + the selector syntax. + + When creating a new output table, the information describing its + columns can be taken from two sources. If parameter 'template' has + the name of an existing 3-D table, the column descriptions, + including maximum array sizes, will be taken from that table. If + 'template' has an invalid or null ("") value, the column-defining + information will be take from the first table in the input list, + where its number of rows will define the maximum array size allowed + in the table being created. Column selectors are allowed in the + template table. + + NOTE: Both the output and template table names must always be + supplied complete, including their extension. Otherwise the task + may get confused on the existence of an already existing table. + + Insertion is performed by first verifying if column names in both + input and output tables match. If a match is found, values taken + from that column and all selected rows from the input table will be + stored as a 1-dimensional array in a single cell in the + corresponding column in the output 3-D table. The row in this + table where the insertion takes place is selected by the "row" task + parameter. It points to the row where the first table in the input + list will be inserted, subsequent tables in the list will be + inserted into subsequent rows. This mechanism is superseded if the + "row" parameter is set to INDEF or a negative value, and the + keyword "ORIG_ROW" is found in the header of the input table. This + keyword is created by task txtable and its value supersedes the row + counter in the task. + If the maximum array size in a target column in the output 3-D + table is larger than the number of selected input rows, the array + will be filled up starting from its first element, and the empty + elements at the end will be set to INDEF (or "" if it is a + character string column). If the maximum array size is smaller than + the number of selected rows, insertion begins by the first selected + row up to the maximum allowable size, the remaining rows being + ignored. + + This task correctly handles scalars stored in the input table header + by task txtable. Since the selector mechanism does not work with + these scalars, the task will always insert them into the output + table, provided there is a match in column names. + + +PARAMETERS + + intable [file name list/template] + A list of one or more tables to be inserted. Row/column + selectors are supported. + + outtable [table name] + Name of 3-D output table, including extension. No support + exists for "STDOUT" (ASCII output). + + (template = "") [table name] + Name of 3-D table to be used as template when creating a new + output table. + + (row = INDEF) [int] + Row where insertion begins. If set to INDEF or a negative + value, the row number will be looked for in the input table + header. + + (verbose = yes) [boolean] + Display names of input and output tables as files are processed + ? + + +EXAMPLES + Insert columns named FLUX and WAVELENGTH from input tables into a + 3-D table: + + cl> titable itable*.tab[c:FLUX,WAVELENGTH] otable.tab + + + +BUGS + The output and template table names must be supplied in full, + including the extension (e.g. ".tab"). If the output table name is + not typed in full, the task will create a new table in place of the + existing one, with only the rows actually inserted. This behavior + relates to the way the underlying "access" routine in IRAF's fio + library works. + + +REFERENCES + This task was written by I. Busko. + + +SEE ALSO + txtable, selectors +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{loc.txt} +\begin{verbatim} + +Filename Total Blanks Comments Help Execute Nonexec +============================================================================ + titable.x 81 18 16 0 23 24 + tiupdate.x 42 13 11 0 7 11 + tinew.x 96 24 21 0 30 21 + tinsert.x 104 23 17 0 41 23 + tisetc.x 70 17 14 0 20 19 + ticopy.x 107 23 16 0 45 23 + ticc.x 53 11 7 0 22 13 + tiheader.x 189 57 27 0 62 43 +TOTAL 742 186 129 0 250 177 +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{titable.x} +\begin{verbatim} + +include + +# TITABLE -- Insert 2D tables into 3D table rows. +# +# Input tables are given by a filename template list. All row/column +# selection on input tables is performed by bracket-enclosed selectors +# appended to the file name. The output is a 3-D table with no row/column +# selectors. +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) + + +procedure t_titable() + +char tablist[SZ_LINE] # Input table list +char output[SZ_PATHNAME] # Output table name +char template[SZ_PATHNAME] # Template table name +int row # Row where to begin insertion +bool verbose # Print operations ? +#-- +char root[SZ_FNAME] +char rowselect[SZ_FNAME] +char colselect[SZ_FNAME] +char colname[SZ_COLNAME] +char colunits[SZ_COLUNITS] +char colfmt[SZ_COLFMT] +pointer cpo +pointer otp, list +int ncpo, rowc +bool rflag + +string nocols "Column name not found (%s)" +string nofile "Input file is not a table (%s)" + +pointer imtopen() +int clgeti(), access() +bool clgetb(), streq() + +begin + # Get task parameters. + + call clgstr ("intable", tablist, SZ_LINE) + call clgstr ("outtable", output, SZ_PATHNAME) + call clgstr ("template", template, SZ_PATHNAME) + row = clgeti ("row") + verbose = clgetb ("verbose") + + # Abort if invalid output name.. + if (streq (output, "STDOUT")) + call error (1, "Invalid output file name.") + call rdselect (output, root, rowselect, colselect, SZ_FNAME) + if (rowselect[1] != EOS || colselect[1] != EOS) + call error (1, "Sections not permitted on output table name.") + + # Open input list. + list = imtopen (tablist) + + # Open/create the output table. + if (access (output, READ_WRITE, 0) == YES) + call tiupdate (root, otp, cpo, ncpo) + else + call tinew (template, list, root, rowselect, colselect, colname, + colunits, colfmt, otp, cpo, ncpo) + + # Initialize row counter. + rowc = row + rflag = false + if (rowc <= 0 || IS_INDEF(rowc)) rflag = true + + # Do the insertion. + call tinsert (list, output, otp, cpo, ncpo, rowc, rflag, verbose, + rowselect, colselect, colname, colunits, colfmt) + + # Cleanup. The cpo array was allocated by tiupdate/tinew. + call tcs_close (Memi[cpo], ncpo) + call mfree (cpo, TY_INT) + call tbtclo (otp) + call imtclose (list) +end +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{tiupdate.x} +\begin{verbatim} + +include + +# TIUPDATE -- Opens an already existing output table for update. +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) + + +procedure tiupdate (output, otp, cpo, ncpo) + +char output[ARB] # i: table name +pointer otp # o: table descriptor +pointer cpo # o: column descriptor +int ncpo # o: number of columns +#-- +int i, dummy + +errchk tbtopn + +pointer tbtopn(), tcs_column() +int tbpsta() + +begin + # Open table and get its size. + otp = tbtopn (output, READ_WRITE, NULL) + ncpo = tbpsta (otp, TBL_NCOLS) + + # Alloc column descriptor array. This + # must be freed by caller. + call malloc (cpo, ncpo, TY_INT) + + # Fill array with column info. The empty string + # forces the opening of all columns. + call tcs_open (otp, "", Memi[cpo], dummy, ncpo) + + # Get column pointers from tcs structure. + do i = 1, ncpo + Memi[cpo+i-1] = tcs_column (Memi[cpo+i-1]) +end +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{tinew.x} +\begin{verbatim} + +include +include "../whatfile.h" + +# TINEW -- Opens and creates a new output table. +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) + + +procedure tinew (template, list, output, rowsel, colsel, colname, colunits, + colfmt, otp, cpo, ncpo) + +char template[ARB] # i: template table name +pointer list # i: input list +char output[ARB] # i: output table name +char rowsel[ARB] # i: work array for row selectors +char colsel[ARB] # i: work array for column selectors +char colname[ARB] # i: work array for column names +char colunits[ARB] # i: work array for column units +char colfmt[ARB] # i: work array for column format +pointer otp # o: table descriptor +pointer cpo # o: column descriptor +int ncpo # o: number of columns +#-- +pointer sp, itp, newcpo, root +int nrows, ncols, nscalar +bool is_temp + +errchk tbtopen, tisetc + +pointer tbtopn() +int tbpsta(), whatfile(), imtgetim(), tihnsc(), access() + +begin + call smark (sp) + call salloc (root, SZ_PATHNAME, TY_CHAR) + + # See if there is a template table. + is_temp = true + if (access (template, READ_ONLY, 0) == NO) { + + # Get first table in input list as the template. + if (imtgetim (list, template, SZ_PATHNAME) == EOF) + call error (1, "Input list is empty.") + call imtrew (list) + is_temp = false + } + + if (whatfile (template) != IS_TABLE) + call error (1, "Template/input file is not a table.") + + # Break template file name into bracketed selectors. + call rdselect (template, Memc[root], rowsel, colsel, SZ_FNAME) + + # Open template table and get some info. + itp = tbtopn (Memc[root], READ_ONLY, NULL) + nrows = tbpsta (itp, TBL_NROWS) + ncols = tbpsta (itp, TBL_NCOLS) + + # There might be header-stored scalars that don't show up + # with tbpsta, if the template is coming from the input list. + # Examine the header to find how many of them there are and + # increment number of output columns. + nscalar = tihnsc (itp) + ncols = ncols + nscalar + + # Create arrays with colum info. Must be freed by caller. + call malloc (cpo, ncols, TY_INT) + call malloc (newcpo, ncols, TY_INT) + call tcs_open (itp, colsel, Memi[cpo], ncpo, ncols) + + # Exit if no column matches and no scalars. + if (ncpo == 0 && nscalar == 0) + call error (1, "No columns selected.") + + # Open output table. + otp = tbtopn (output, NEW_FILE, 0) + + # Copy column information from input to output. + call tisetc (cpo, newcpo, ncpo, nscalar, itp, otp, colname, colunits, + colfmt, nrows, is_temp) + + # Point to new column array. + call mfree (cpo, TY_INT) + cpo = newcpo + + # Number of columns now is (selected columns from input) + scalars. + ncpo = ncpo + nscalar + + # Create output table. + call tbtcre (otp) + + # Cleanup. + call tbtclo (itp) + call sfree (sp) +end +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{tinsert.x} +\begin{verbatim} + +include +include "../whatfile.h" + +# TINSERT -- Perform the actual insertion. +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) + + +procedure tinsert (list, output, otp, cpo, ncpo, row, rflag, verbose, + rowsel, colsel, colname, colunits, colfmt) + +pointer list # i: input list +char output[ARB] # i: output table name +pointer otp # i: output table descriptor +pointer cpo # i: output column descriptors +int ncpo # i: output number of columns +int row # i: row where to begin insertion +bool rflag # i: read row from header ? +bool verbose # i: print info ? +char rowsel[ARB] # i: work string for row selector +char colsel[ARB] # i: work string for column selector +char colname[ARB] # i: work string for column names +char colunits[ARB] # i: work string for column units +char colfmt[ARB] # i: work string for column formats +#-- +pointer sp, itp, fname, root, pcode, cpi +int i, file, hrow, numrow, numcol, nrows, ncpi + +errchk ticopy + +pointer trsopen(), tbtopn() +int imtgetim(), imtlen(), whatfile(), tihrow(), tbpsta() +bool trseval() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (root, SZ_FNAME, TY_CHAR) + + # Loop over input list. + do file = 1, imtlen(list) { + + # Get input table name and validate file type. + i = imtgetim (list, Memc[fname], SZ_PATHNAME) + if (whatfile (Memc[fname]) != IS_TABLE) { + call eprintf ("Input file is not a table (%s)\n") + call pargstr (Memc[fname]) + call flush (STDERR) + break + } + + # Break input file name into bracketed selectors. + call rdselect (Memc[fname], Memc[root], rowsel, colsel, SZ_FNAME) + + # Open input table and get some info. + itp = tbtopn (Memc[fname], READ_ONLY, NULL) + numrow = tbpsta (itp, TBL_NROWS) + numcol = tbpsta (itp, TBL_NCOLS) + + # See if original row information is stored in header. + # If so, and user asked for, use it. + hrow = tihrow (itp) + if (rflag) { + if (hrow > 0) + row = hrow + else + call error (1, "No valid row.") + } + + # Find how many rows were requested by row selector. + nrows = 0 + pcode = trsopen (itp, rowsel) + do i = 1, numrow { + if (trseval (itp, i, pcode)) + nrows = nrows + 1 + } + call trsclose (pcode) + + # Create array of column pointers from column selector. + call malloc (cpi, numcol, TY_INT) + call tcs_open (itp, colsel, Memi[cpi], ncpi, numcol) + + if (verbose) { + call printf ("%s -> %s row=%d \n") + call pargstr (Memc[fname]) + call pargstr (output) + call pargi (row) + call flush (STDOUT) + } + + # Copy current input table into current row of output table. + call ticopy (itp, cpi, ncpi, otp, cpo, ncpo, rowsel, row, nrows, + colname, colunits, colfmt) + + # Free input table's array of column pointers. + call tcs_close (Memi[cpi], ncpi) + call mfree (cpi, TY_INT) + + # Close input table. + call tbtclo (itp) + + # Bump row counter. + row = row + 1 + } + + call sfree (sp) +end +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{tisetc.x} +\begin{verbatim} + + +# TISETC -- Set column info in new output table. +# +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) + + +procedure tisetc (cpo, newcpo, ncpo, nscalar, itp, otp, colname, colunits, + colfmt, csize, template) + +pointer cpo # i: array of column descriptors +pointer newcpo # io: new array of column descriptors +int ncpo # i: number of columns matched by selector +int nscalar # i: number of scalar columns +char colname[ARB] # i: work array for column names +char colunits[ARB] # i: work array for column units +char colfmt[ARB] # i: work array for column format +pointer itp,otp # io: template and output table descriptors +int csize # i: cell size in output table +bool template # i: is there a template ? +#-- +pointer ocp +int i, j, colnum, ntot +int datatype, lendata, lenfmt + +errchk tihdec + +pointer tcs_column() +int tihmax() +bool tihdec() + +begin + # First copy column information from template/input + # table into output table. + if (ncpo > 0) { + do i = 1, ncpo { + ocp = tcs_column (Memi[cpo+i-1]) + if (!template) { + + # Template wasn't supplied; copy column info from 2-D + # input table into 3-D output table, taking care of + # resetting the array size. + call tbcinf (ocp, colnum, colname, colunits, colfmt, + datatype, lendata, lenfmt) + if (lendata > 1) + call error (1, "Input table has array element !") + call tbcdef (otp, ocp, colname, colunits, colfmt, + datatype, csize, 1) + } else { + + # Copy with same array size configuration, since + # template is supposedly a 3-D table. + call tbcinf (ocp, colnum, colname, colunits, colfmt, + datatype, lendata, lenfmt) + call tbcdef (otp, ocp, colname, colunits, colfmt, + datatype, lendata, 1) + } + + # Save column pointer. + Memi[newcpo+i-1] = ocp + } + } + + # If header-stored scalars exist, define new columns for them. + if (nscalar > 0) { + ntot = tihmax (itp) + i = ncpo + do j = 1, ntot { + if (tihdec (itp, j, colname, colunits, colfmt, datatype, + lenfmt)) { + call tbcdef (otp, ocp, colname, colunits, colfmt, + datatype, 1, 1) + Memi[newcpo+i] = ocp + i = i + 1 + } + } + } +end + +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{ticopy.x} +\begin{verbatim} + +include + +# TICOPY -- Copy input table into row of output table +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) + + +procedure ticopy (itp, cpi, ncpi, otp, cpo, ncpo, rowsel, row, nrows, + coln, colu, colf) + +pointer itp # i: input table descriptor +pointer cpi # i: input column descriptor array +int ncpi # i: input number of columns +pointer otp # i: output table descriptor +pointer cpo # i: output column descriptor array +int ncpo # i: output number of columns +char rowsel[ARB] # i: work string for row selector +int row # i: row where to begin insertion +int nrows # i: number of selected rows +char coln[ARB] # i: work string for column names +char colu[ARB] # i: work string for column units +char colf[ARB] # i: work string for column formats +#-- +pointer sp, coln2, colu2, colf2, icp, ocp +int icpi, icpo, dum, dtypi, dtypo, maxlen +int ihc, maxhc +bool found + +errchk ticc + +pointer tcs_column() +int tbalen(), tihmax() +bool streq(), tihdec() + +begin + call smark (sp) + call salloc (coln2, SZ_COLNAME, TY_CHAR) + call salloc (colu2, SZ_COLUNITS, TY_CHAR) + call salloc (colf2, SZ_COLFMT, TY_CHAR) + + # Loop over output table column pointers. + do icpo = 1, ncpo { + + # Get column name and data type from output table. + ocp = Memi[cpo+icpo-1] + call tbcinf (ocp, dum, coln, colu, colf, dtypo, dum, dum) + + # Array length must be the minimum in between table array + # size and the number of rows selected from input table. + maxlen = min (tbalen(ocp), nrows) + + # If there are matched columns, loop over + # input table column pointers. + found = false + if (ncpi > 0) { + do icpi = 1, ncpi { + + # Get column name and data type from input table. + icp = tcs_column (Memi[cpi+icpi-1]) + call tbcinf (icp,dum,Memc[coln2],colu,colf,dtypi,dum,dum) + + # If column names match, copy from table to table. + if (streq (coln, Memc[coln2])) { + # For now, abort if datatypes do not match. + if (dtypo != dtypi) + call error (1, "Data types do not match.") + call ticc (itp,icp,otp,ocp,dtypo,maxlen,rowsel,row) + found = true + } + } + } + + # If column was not found, look into header. + if (!found) { + maxhc = tihmax (itp) + if (maxhc > 0) { + do ihc = 1, maxhc { + if (tihdec (itp, ihc, Memc[coln2], Memc[colu2], + Memc[colf2], dtypi, dum)) { + if (streq (coln, Memc[coln2])) { + + # For now, abort if datatypes do not match. + if (dtypo != dtypi) + call error (1, "Data types do not match.") + if (dtypo < 0) + dtypo = TY_CHAR + + switch (dtypo) { + case TY_CHAR: + call ticht (itp, ihc, otp, ocp, row, -dtypi) + case TY_BOOL: + call tichb (itp, ihc, otp, ocp, row) + case TY_SHORT: + call tichs (itp, ihc, otp, ocp, row) + case TY_INT,TY_LONG: + call tichi (itp, ihc, otp, ocp, row) + case TY_REAL: + call tichr (itp, ihc, otp, ocp, row) + case TY_DOUBLE: + call tichd (itp, ihc, otp, ocp, row) + default: + call error (1, "Non-supported data type.") + } + } + } + } + } + } + } + + call sfree (sp) +end + + +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{ticc.x} +\begin{verbatim} + + +# TICC -- Copy data from column in input to cell array in output. +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) + + +procedure ticc (itp, icp, otp, ocp, dtype, maxlen, rowsel, row) + +pointer itp # i: input table descriptor +pointer icp # i: input column descriptor +pointer otp # i: output table descriptor +pointer ocp # i: output column descriptor +int dtype # i: data type of both input and output columns +int maxlen # i: array length +char rowsel[ARB] # i: work string for row selector +int row # i: row where to insert +#-- +pointer sp, buf +int maxch + +begin + # Alloc buffer of apropriate length and type. + maxch = 1 + if (dtype < 0) { + maxch = - dtype + dtype = TY_CHAR + } + call smark (sp) + call salloc (buf, maxlen*(maxch + 1), dtype) + + # Copy. + switch (dtype) { + case TY_CHAR: + call tirowst (itp, icp, otp, ocp, rowsel, row, maxch, maxlen, + Memc[buf]) + case TY_BOOL: + call tirowsb (itp, icp, otp, ocp, rowsel, row, maxlen, Memb[buf]) + case TY_SHORT: + call tirowss (itp, icp, otp, ocp, rowsel, row, maxlen, Mems[buf]) + case TY_INT, TY_LONG: + call tirowsi (itp, icp, otp, ocp, rowsel, row, maxlen, Memi[buf]) + case TY_REAL: + call tirowsr (itp, icp, otp, ocp, rowsel, row, maxlen, Memr[buf]) + case TY_DOUBLE: + call tirowsd (itp, icp, otp, ocp, rowsel, row, maxlen, Memd[buf]) + default: + call error (1, "Non-supported data type.") + } + + call sfree (sp) +end +\end{verbatim} +\newpage +\addcontentsline{toc}{section}{tiheader.x} +\begin{verbatim} + +include + +# TIHEADER -- Routines for retrieving header-stored scalars. +# +# Details such as keyword names and encoding are defined by the +# way task txtable creates the same keywords. +# +# +# +# TIHKI -- Look for keyword and return integer value, or 0 if not found. +# TIHMAX -- Return maximum number of header-stored scalars. +# TIHNSC -- Return actual number of scalars in header. +# TIHROW -- Return original row value stored by txtable task. +# TIHDEC -- Decode column description in header keyword. +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) + + + +# TIHMAX -- Return maximum number of header-stored scalars. + +int procedure tihmax (tp) + +pointer tp # table pointer + +int tihki() + +begin + return (tihki (tp, "TCTOTAL")) +end + + + + +# TIHROW -- Return original row value (stored by txtable task). + +int procedure tihrow (tp) + +pointer tp # table pointer + +int tihki() + +begin + return (tihki (tp, "ORIG_ROW")) +end + + + + +# TIHNSC -- Return actual number of scalars in header. + +int procedure tihnsc (tp) + +pointer tp # table pointer +#-- +pointer sp, kwname, kwval +int dtype, parnum +int i, ntot, nscalar + +int tihmax() + +begin + call smark (sp) + call salloc (kwval, SZ_PARREC, TY_CHAR) + call salloc (kwname, SZ_LINE, TY_CHAR) + nscalar = 0 + + ntot = tihmax (tp) + if (ntot > 0) { + do i = 1, ntot { + call sprintf (kwname, SZ_LINE, "TCD_%03d") + call pargi (i) + call tbhfkr (tp, kwname, dtype, kwval, parnum) + if (parnum > 0) + nscalar = nscalar + 1 + } + } + + call sfree (sp) + return (nscalar) +end + + + + + +# TIHDEC -- Decode column description in header keyword. The detailed +# format depends on how task txtable does the encoding. + +bool procedure tihdec (tp, kn, colname, colunits, colfmt, datatype, lenfmt) + +pointer tp # i: table pointer +int kn # i: keyword number +char colname[ARB] # o: column name +char colunits[ARB] # o: column units +char colfmt[ARB] # o: column print format +int datatype # o: column data type +int lenfmt # o: format lenght +#-- +pointer sp, kwname, kwval, dtype +int parnum +bool found + +string corrupt "Corrupted header in input table." + +int nscan(), strncmp() +bool streq() + +begin + call smark (sp) + call salloc (kwval, SZ_PARREC, TY_CHAR) + call salloc (kwname, SZ_LINE, TY_CHAR) + call salloc (dtype, SZ_LINE, TY_CHAR) + + # Build column description keyword name. + call sprintf (Memc[kwname], SZ_LINE, "TCD_%03d") + call pargi (kn) + + # Look for it. + call tbhfkr (tp, Memc[kwname], datatype, Memc[kwval], parnum) + + if (parnum > 0) { + + # Found; parse the 5 fields. + call sscan (Memc[kwval]) + call gargwrd (colname, SZ_COLNAME) + if (nscan() < 1) call error (1, corrupt) + call gargwrd (colunits, SZ_COLUNITS) + if (nscan() < 1) call error (1, corrupt) + call gargwrd (colfmt, SZ_COLFMT) + if (nscan() < 1) call error (1, corrupt) + call gargwrd (Memc[dtype], SZ_LINE) + if (nscan() < 1) call error (1, corrupt) + call gargi (lenfmt) + if (nscan() < 1) call error (1, corrupt) + + # Translate from human-readable encoding to sdas table encoding. + if (streq (colunits, "default")) + call strcpy ("", colunits, SZ_COLUNITS) + if (streq (colfmt, "default")) + call strcpy ("", colfmt, SZ_COLFMT) + if (streq (Memc[dtype], "boolean")) datatype = TY_BOOL + if (streq (Memc[dtype], "short")) datatype = TY_SHORT + if (streq (Memc[dtype], "integer")) datatype = TY_INT + if (streq (Memc[dtype], "long")) datatype = TY_LONG + if (streq (Memc[dtype], "real")) datatype = TY_REAL + if (streq (Memc[dtype], "double")) datatype = TY_DOUBLE + if (strncmp (Memc[dtype], "character_", 10) == 0) { + call sscan (Memc[dtype+10]) + call gargi (datatype) + datatype = -datatype + } + found = true + } else + found = false + + call sfree (sp) + return (found) +end + + + + +# TIHKI -- Look for keyword and return integer value, or 0 if not found. +# Zero is never expected as a valid result because this routine +# is used to retrieve either the maximum number of header-stored +# scalars (zero means no scalars) or the original table row number. + +int procedure tihki (tp, keyword) + +pointer tp # table pointer +char keyword[ARB] # keyword +#-- +pointer sp, kwval +int dtype, parnum, par + +int tbhgti() + +begin + call smark (sp) + call salloc (kwval, SZ_PARREC, TY_CHAR) + call tbhfkr (tp, keyword, dtype, kwval, parnum) + if (parnum > 0) + par = tbhgti (tp, keyword) + else + par = 0 + call sfree (sp) + return (par) +end +\end{verbatim} +\newpage +\end{document} diff --git a/pkg/utilities/nttools/threed/titable/loc.txt b/pkg/utilities/nttools/threed/titable/loc.txt new file mode 100644 index 00000000..1621316e --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/loc.txt @@ -0,0 +1,11 @@ +Filename Total Blanks Comments Help Execute Nonexec +============================================================================ + titable.x 81 18 16 0 23 24 + tiupdate.x 42 13 11 0 7 11 + tinew.x 96 24 21 0 30 21 + tinsert.x 104 23 17 0 41 23 + tisetc.x 70 17 14 0 20 19 + ticopy.x 107 23 16 0 45 23 + ticc.x 53 11 7 0 22 13 + tiheader.x 189 57 27 0 62 43 +TOTAL 742 186 129 0 250 177 diff --git a/pkg/utilities/nttools/threed/titable/mkpkg b/pkg/utilities/nttools/threed/titable/mkpkg new file mode 100644 index 00000000..c84da84b --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/mkpkg @@ -0,0 +1,36 @@ +# Update the titable application code in the threed package library. +# Author: I.Busko, 14-Jan-1997 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +# This module is called from the threed mkpkg. +generic: + $ifnfile (generic/tirowsi.x) + $generic -k -p generic/ -t bcsird tirows.gx + $endif + $ifolder (generic/tirowsi.x, tirows.gx) + $generic -k -p generic/ -t bcsird tirows.gx + $endif + $ifnfile (generic/tichi.x) + $generic -k -p generic/ -t bcsird tich.gx + $endif + $ifolder (generic/tichi.x, tich.gx) + $generic -k -p generic/ -t bcsird tich.gx + $endif + ; + +libpkg.a: + @generic + ticc.x + ticopy.x + tiheader.x + tinew.x + tinsert.x + tisetc.x + titable.x + tiupdate.x + ; + diff --git a/pkg/utilities/nttools/threed/titable/ticc.x b/pkg/utilities/nttools/threed/titable/ticc.x new file mode 100644 index 00000000..81283904 --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/ticc.x @@ -0,0 +1,56 @@ + +# TICC -- Copy data from column in input to cell array in output. +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) + + +procedure ticc (itp, icp, otp, ocp, dtype, maxlen, rowsel, row) + +pointer itp # i: input table descriptor +pointer icp # i: input column descriptor +pointer otp # i: output table descriptor +pointer ocp # i: output column descriptor +int dtype # i: data type of both input and output columns +int maxlen # i: array length +char rowsel[ARB] # i: work string for row selector +int row # i: row where to insert +#-- +pointer sp, buf +int maxch + +begin + # Alloc buffer of apropriate length and type. + maxch = 1 + if (dtype < 0) { + maxch = - dtype + dtype = TY_CHAR + } + call smark (sp) + call salloc (buf, maxlen*(maxch + 1), dtype) + + # Copy. + switch (dtype) { + case TY_CHAR: + call tirowst (itp, icp, otp, ocp, rowsel, row, maxch, maxlen, + Memc[buf]) + case TY_BOOL: + call tirowsb (itp, icp, otp, ocp, rowsel, row, maxlen, Memb[buf]) + case TY_SHORT: + call tirowss (itp, icp, otp, ocp, rowsel, row, maxlen, Mems[buf]) + case TY_INT, TY_LONG: + call tirowsi (itp, icp, otp, ocp, rowsel, row, maxlen, Memi[buf]) + case TY_REAL: + call tirowsr (itp, icp, otp, ocp, rowsel, row, maxlen, Memr[buf]) + case TY_DOUBLE: + call tirowsd (itp, icp, otp, ocp, rowsel, row, maxlen, Memd[buf]) + default: + call error (1, "Non-supported data type.") + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/threed/titable/tich.gx b/pkg/utilities/nttools/threed/titable/tich.gx new file mode 100644 index 00000000..bcc83fef --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/tich.gx @@ -0,0 +1,74 @@ +include + +# TICH -- Copy data from input header into scalar cell in output. +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) + + +$if (datatype == c) +procedure ticht (itp, ihc, otp, ocp, orow, maxch) +$else +procedure tich$t (itp, ihc, otp, ocp, orow) +$endif + +pointer itp # i: input table descriptor +int ihc # i: header keyword index +pointer otp # i: output table descriptor +pointer ocp # i: output column descriptor +int orow # i: row where to insert +$if (datatype == c) +int maxch +$endif +#-- +$if (datatype == c) +pointer buf +$else +PIXEL buf +$endif +pointer sp, kwname, kwval +int datatype, parnum + +string corrupt "Corrupted header in input table." + +int nscan() + +begin + call smark (sp) + $if (datatype == c) + call salloc (buf, maxch + 1, TY_CHAR) + $endif + call salloc (kwname, SZ_LINE, TY_CHAR) + call salloc (kwval, SZ_PARREC, TY_CHAR) + + # Build keyword name and look for it. + call sprintf (Memc[kwname], SZ_LINE, "TCV_%03d") + call pargi (ihc) + call tbhfkr (itp, Memc[kwname], datatype, Memc[kwval], parnum) + + # Parse and read value. We assume that the keyword existence + # was confirmed by previously finding the paired TCD_ keyword. + if (parnum > 0) { + call sscan (Memc[kwval]) + $if (datatype == c) + call gargwrd (buf, maxch) + $else + call garg$t (buf) + $endif + if (nscan() < 1) call error (1, corrupt) + } else + call error (1, corrupt) + + # Write value into scalar cell. + $if (datatype == c) + call tbcptt (otp, ocp, buf, maxch, orow, orow) + $else + call tbcpt$t (otp, ocp, buf, orow, orow) + $endif + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/threed/titable/ticopy.x b/pkg/utilities/nttools/threed/titable/ticopy.x new file mode 100644 index 00000000..505a80ce --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/ticopy.x @@ -0,0 +1,116 @@ +include + +# TICOPY -- Copy input table into row of output table +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) +# 17-Mar-97 - Revised after code review (IB) + + +procedure ticopy (itp, cpi, ncpi, otp, cpo, ncpo, rowsel, row, nrows, + coln, colu, colf) + +pointer itp # i: input table descriptor +pointer cpi # i: input column descriptor array +int ncpi # i: input number of columns +pointer otp # i: output table descriptor +pointer cpo # i: output column descriptor array +int ncpo # i: output number of columns +char rowsel[ARB] # i: work string for row selector +int row # i: row where to begin insertion +int nrows # i: number of selected rows +char coln[ARB] # i: work string for column names +char colu[ARB] # i: work string for column units +char colf[ARB] # i: work string for column formats +#-- +pointer sp, coln2, colu2, colf2, icp, ocp +int icpi, icpo, dum, dtypi, dtypo, maxlen +int ihc, maxhc +bool found + +errchk ticc + +pointer tcs_column() +int tbalen(), tihmax() +bool streq(), tihdec() + +begin + call smark (sp) + call salloc (coln2, SZ_COLNAME, TY_CHAR) + call salloc (colu2, SZ_COLUNITS, TY_CHAR) + call salloc (colf2, SZ_COLFMT, TY_CHAR) + + # Loop over output table column pointers. + do icpo = 1, ncpo { + + # Get column name and data type from output table. + ocp = Memi[cpo+icpo-1] + call tbcinf (ocp, dum, coln, colu, colf, dtypo, dum, dum) + + # Array length must be the minimum in between table array + # size and the number of rows selected from input table. + maxlen = min (tbalen(ocp), nrows) + + # If there are matched columns, loop over + # input table column pointers. + found = false + do icpi = 1, ncpi { + + # Get column name and data type from input table. + icp = tcs_column (Memi[cpi+icpi-1]) + call tbcinf (icp,dum,Memc[coln2],colu,colf,dtypi,dum,dum) + + # If column names match, copy from table to table. + if (streq (coln, Memc[coln2])) { + # For now, abort if datatypes do not match. + if (dtypo != dtypi) + call error (1, "Data types do not match.") + call ticc (itp,icp,otp,ocp,dtypo,maxlen,rowsel,row) + found = true + } + } + + # If column was not found, look into header. + if (!found) { + maxhc = tihmax (itp) + do ihc = 1, maxhc { + if (tihdec (itp, ihc, Memc[coln2], Memc[colu2], + Memc[colf2], dtypi, dum)) { + if (streq (coln, Memc[coln2])) { + + # For now, abort if datatypes do not match. + if (dtypo != dtypi) + call error (1, "Data types do not match.") + if (dtypo < 0) + dtypo = TY_CHAR + + switch (dtypo) { + case TY_CHAR: + call ticht (itp, ihc, otp, ocp, row, -dtypi) + case TY_BOOL: + call tichb (itp, ihc, otp, ocp, row) + case TY_SHORT: + call tichs (itp, ihc, otp, ocp, row) + case TY_INT,TY_LONG: + call tichi (itp, ihc, otp, ocp, row) + case TY_REAL: + call tichr (itp, ihc, otp, ocp, row) + case TY_DOUBLE: + call tichd (itp, ihc, otp, ocp, row) + default: + call error (1, "Non-supported data type.") + } + } + } + } + } + } + + call sfree (sp) +end + + diff --git a/pkg/utilities/nttools/threed/titable/tiheader.x b/pkg/utilities/nttools/threed/titable/tiheader.x new file mode 100644 index 00000000..4918b625 --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/tiheader.x @@ -0,0 +1,192 @@ +include + +# TIHEADER -- Routines for retrieving header-stored scalars. +# +# Details such as keyword names and encoding are defined by the +# way task txtable creates the same keywords. +# +# +# +# TIHKI -- Look for keyword and return integer value, or 0 if not found. +# TIHMAX -- Return maximum number of header-stored scalars. +# TIHNSC -- Return actual number of scalars in header. +# TIHROW -- Return original row value stored by txtable task. +# TIHDEC -- Decode column description in header keyword. +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) +# 17-Mar-97 - Revised after code review (IB) + + + +# TIHMAX -- Return maximum number of header-stored scalars. + +int procedure tihmax (tp) + +pointer tp # table pointer + +int tihki() + +begin + return (tihki (tp, "TCTOTAL")) +end + + + + +# TIHROW -- Return original row value (stored by txtable task). + +int procedure tihrow (tp) + +pointer tp # table pointer + +int tihki() + +begin + return (tihki (tp, "ORIG_ROW")) +end + + + + +# TIHNSC -- Return actual number of scalars in header. + +int procedure tihnsc (tp) + +pointer tp # table pointer +#-- +pointer sp, kwname, kwval +int dtype, parnum +int i, ntot, nscalar + +int tihmax() + +begin + call smark (sp) + call salloc (kwval, SZ_PARREC, TY_CHAR) + call salloc (kwname, SZ_LINE, TY_CHAR) + nscalar = 0 + + ntot = tihmax (tp) + do i = 1, ntot { + call sprintf (kwname, SZ_LINE, "TCD_%03d") + call pargi (i) + call tbhfkr (tp, kwname, dtype, kwval, parnum) + if (parnum > 0) + nscalar = nscalar + 1 + } + + call sfree (sp) + return (nscalar) +end + + + + + +# TIHDEC -- Decode column description in header keyword. The detailed +# format depends on how task txtable does the encoding. + +bool procedure tihdec (tp, kn, colname, colunits, colfmt, datatype, lenfmt) + +pointer tp # i: table pointer +int kn # i: keyword number +char colname[ARB] # o: column name +char colunits[ARB] # o: column units +char colfmt[ARB] # o: column print format +int datatype # o: column data type +int lenfmt # o: format lenght +#-- +pointer sp, kwname, kwval, dtype +int parnum +bool found + +string corrupt "Corrupted header in input table." + +int nscan(), strncmp() +bool streq() + +begin + call smark (sp) + call salloc (kwval, SZ_PARREC, TY_CHAR) + call salloc (kwname, SZ_LINE, TY_CHAR) + call salloc (dtype, SZ_LINE, TY_CHAR) + + # Build column description keyword name. + call sprintf (Memc[kwname], SZ_LINE, "TCD_%03d") + call pargi (kn) + + # Look for it. + call tbhfkr (tp, Memc[kwname], datatype, Memc[kwval], parnum) + + if (parnum > 0) { + + # Found; parse the 5 fields. + call sscan (Memc[kwval]) + call gargwrd (colname, SZ_COLNAME) + if (nscan() < 1) call error (1, corrupt) + call gargwrd (colunits, SZ_COLUNITS) + if (nscan() < 1) call error (1, corrupt) + call gargwrd (colfmt, SZ_COLFMT) + if (nscan() < 1) call error (1, corrupt) + call gargwrd (Memc[dtype], SZ_LINE) + if (nscan() < 1) call error (1, corrupt) + call gargi (lenfmt) + if (nscan() < 1) call error (1, corrupt) + + # Translate from human-readable encoding to sdas table encoding. + if (streq (colunits, "default")) + call strcpy ("", colunits, SZ_COLUNITS) + if (streq (colfmt, "default")) + call strcpy ("", colfmt, SZ_COLFMT) + if (streq (Memc[dtype], "boolean")) datatype = TY_BOOL + if (streq (Memc[dtype], "short")) datatype = TY_SHORT + if (streq (Memc[dtype], "integer")) datatype = TY_INT + if (streq (Memc[dtype], "long")) datatype = TY_LONG + if (streq (Memc[dtype], "real")) datatype = TY_REAL + if (streq (Memc[dtype], "double")) datatype = TY_DOUBLE + if (strncmp (Memc[dtype], "character_", 10) == 0) { + call sscan (Memc[dtype+10]) + call gargi (datatype) + datatype = -datatype + } + found = true + } else + found = false + + call sfree (sp) + return (found) +end + + + + +# TIHKI -- Look for keyword and return integer value, or 0 if not found. +# Zero is never expected as a valid result because this routine +# is used to retrieve either the maximum number of header-stored +# scalars (zero means no scalars) or the original table row number. + +int procedure tihki (tp, keyword) + +pointer tp # table pointer +char keyword[ARB] # keyword +#-- +pointer sp, kwval +int dtype, parnum, par + +int tbhgti() + +begin + call smark (sp) + call salloc (kwval, SZ_PARREC, TY_CHAR) + call tbhfkr (tp, keyword, dtype, kwval, parnum) + if (parnum > 0) + par = tbhgti (tp, keyword) + else + par = 0 + call sfree (sp) + return (par) +end diff --git a/pkg/utilities/nttools/threed/titable/tinew.x b/pkg/utilities/nttools/threed/titable/tinew.x new file mode 100644 index 00000000..afc63bcb --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/tinew.x @@ -0,0 +1,101 @@ +include + +# TINEW -- Opens and creates a new output table. +# +# +# +# Revision history: +# ---------------- +# 20-Jan-1997 - Task created (I.Busko) +# 8-Apr-1999 - Call tbfpri (Phil Hodge) +# 8-Apr-2002 - Remove the call to whatfile (P. Hodge) +# 8-Dec-2003 - Call tcs_close for cpo. + + +procedure tinew (template, list, output, rowsel, colsel, colname, colunits, + colfmt, otp, cpo, ncpo) + +char template[ARB] # i: template table name +pointer list # i: input list +char output[ARB] # i: output table name +char rowsel[ARB] # i: work array for row selectors +char colsel[ARB] # i: work array for column selectors +char colname[ARB] # i: work array for column names +char colunits[ARB] # i: work array for column units +char colfmt[ARB] # i: work array for column format +pointer otp # o: table descriptor +pointer cpo # o: column descriptor +int ncpo # o: number of columns +#-- +pointer sp, itp, newcpo, root +int nrows, ncols, nscalar +int phu_copied # set by tbfpri and ignored +bool is_temp + +errchk tbfpri, tbtopn, tisetc + +pointer tbtopn() +int tbpsta(), imtgetim(), tihnsc(), access() + +begin + call smark (sp) + call salloc (root, SZ_PATHNAME, TY_CHAR) + + # See if there is a template table. + is_temp = true + if (access (template, READ_ONLY, 0) == NO) { + + # Get first table in input list as the template. + if (imtgetim (list, template, SZ_PATHNAME) == EOF) + call error (1, "Input list is empty.") + call imtrew (list) + is_temp = false + } + + # Break template file name into bracketed selectors. + call rdselect (template, Memc[root], rowsel, colsel, SZ_FNAME) + + # Open template table and get some info. + itp = tbtopn (Memc[root], READ_ONLY, NULL) + nrows = tbpsta (itp, TBL_NROWS) + ncols = tbpsta (itp, TBL_NCOLS) + + # There might be header-stored scalars that don't show up + # with tbpsta, if the template is coming from the input list. + # Examine the header to find how many of them there are and + # increment number of output columns. + nscalar = tihnsc (itp) + ncols = ncols + nscalar + + # Create arrays with colum info. Must be freed by caller. + call malloc (cpo, ncols, TY_INT) + call malloc (newcpo, ncols, TY_INT) + call tcs_open (itp, colsel, Memi[cpo], ncpo, ncols) + + # Exit if no column matches and no scalars. + if (ncpo == 0 && nscalar == 0) + call error (1, "No columns selected.") + + # Open output table. + call tbfpri (Memc[root], output, phu_copied) + otp = tbtopn (output, NEW_FILE, 0) + + # Copy column information from input to output. + call tisetc (cpo, newcpo, ncpo, nscalar, itp, otp, colname, colunits, + colfmt, nrows, is_temp) + + # Point to new column array. + call tcs_close (Memi[cpo], ncpo) + call mfree (cpo, TY_INT) + cpo = newcpo + + # Number of columns now is (selected columns from input) + scalars. + ncpo = ncpo + nscalar + + # Create output table. + call tbtcre (otp) + + # Cleanup. + call tbtclo (itp) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/threed/titable/tinsert.x b/pkg/utilities/nttools/threed/titable/tinsert.x new file mode 100644 index 00000000..9580a66b --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/tinsert.x @@ -0,0 +1,99 @@ +include + +# TINSERT -- Perform the actual insertion. +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) +# 17-Mar-97 - Added selrows function (IB) +# 8-Apr-02 - Remove the call to whatfile (P. Hodge) + + +procedure tinsert (list, output, otp, cpo, ncpo, row, rflag, verbose, + rowsel, colsel, colname, colunits, colfmt) + +pointer list # i: input list +char output[ARB] # i: output table name +pointer otp # i: output table descriptor +pointer cpo # i: output column descriptors +int ncpo # i: output number of columns +int row # i: row where to begin insertion +bool rflag # i: read row from header ? +bool verbose # i: print info ? +char rowsel[ARB] # i: work string for row selector +char colsel[ARB] # i: work string for column selector +char colname[ARB] # i: work string for column names +char colunits[ARB] # i: work string for column units +char colfmt[ARB] # i: work string for column formats +#-- +pointer sp, itp, fname, root, cpi +int i, file, hrow, numrow, numcol, nrows, ncpi + +errchk ticopy + +pointer tbtopn() +int imtgetim(), imtlen(), tihrow(), tbpsta(), selrows() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (root, SZ_FNAME, TY_CHAR) + + # Loop over input list. + do file = 1, imtlen(list) { + + # Get input table name. + i = imtgetim (list, Memc[fname], SZ_PATHNAME) + + # Break input file name into bracketed selectors. + call rdselect (Memc[fname], Memc[root], rowsel, colsel, SZ_FNAME) + + # Open input table and get some info. + itp = tbtopn (Memc[fname], READ_ONLY, NULL) + numrow = tbpsta (itp, TBL_NROWS) + numcol = tbpsta (itp, TBL_NCOLS) + + # See if original row information is stored in header. + # If so, and user asked for, use it. + hrow = tihrow (itp) + if (rflag) { + if (hrow > 0) + row = hrow + else + call error (1, "No valid row.") + } + + # Find how many rows were requested by row selector. + nrows = selrows (itp, rowsel) + + # Create array of column pointers from column selector. + call malloc (cpi, numcol, TY_INT) + call tcs_open (itp, colsel, Memi[cpi], ncpi, numcol) + + if (verbose) { + call printf ("%s -> %s row=%d \n") + call pargstr (Memc[fname]) + call pargstr (output) + call pargi (row) + call flush (STDOUT) + } + + # Copy current input table into current row of output table. + call ticopy (itp, cpi, ncpi, otp, cpo, ncpo, rowsel, row, nrows, + colname, colunits, colfmt) + + # Free input table's array of column pointers. + call tcs_close (Memi[cpi], ncpi) + call mfree (cpi, TY_INT) + + # Close input table. + call tbtclo (itp) + + # Bump row counter. + row = row + 1 + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/threed/titable/tirows.gx b/pkg/utilities/nttools/threed/titable/tirows.gx new file mode 100644 index 00000000..161b39ce --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/tirows.gx @@ -0,0 +1,98 @@ +include + +# +# TIROWS -- Expand row selector into array and copy it into output +# table cell. +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-1997 - Task created (I.Busko) +# 7-Feb-2000 - For datatype = 'c', make buf an array of strings (P.Hodge) + + +$if (datatype == c) +procedure tirowst (itp, icp, otp, ocp, rowsel, orow, maxch, len, buf) +$else +procedure tirows$t (itp, icp, otp, ocp, rowsel, orow, len, buf) +$endif + +pointer itp # i: input table descriptor +pointer icp # i: input column descriptor +pointer otp # i: output table descriptor +pointer ocp # i: output column descriptor +char rowsel[ARB] # i: row selector +int orow # i: row in output table where to write into +$if (datatype == c) +int maxch # i: max length of string +$endif +int len # i: buffer length +$if (datatype == c) +char buf[maxch,ARB] # i: work buffer +$else +PIXEL buf[ARB] +$endif +#-- +double undefd +real undefr +pointer pcode +int undefi, i, nelem, irow, numrow, alength +short undefs + +pointer trsopen() +int tbpsta(), tbalen() +bool trseval() + +begin + # Loop over selected rows on input table. + pcode = trsopen (itp, rowsel) + numrow = tbpsta (itp, TBL_NROWS) + nelem = 0 + do irow = 1, numrow { + if (trseval (itp, irow, pcode)) { + nelem = nelem + 1 + if (nelem > len) { + nelem = len + break + } + # Get element and store in buffer. + $if (datatype == c) + call tbegtt (itp, icp, irow, buf[1,nelem], maxch) + $else + call tbegt$t (itp, icp, irow, buf[nelem]) + $endif + } + } + call trsclose (pcode) + + # Write buffer into array cell element. + $if (datatype == c) + call tbaptt (otp, ocp, orow, buf, maxch, 1, nelem) + $else + call tbapt$t (otp, ocp, orow, buf, 1, nelem) + $endif + + # If number of selected rows in current input table + # is smaller than output table array length, fill + # remaining array elements with INDEF. + alength = tbalen (ocp) + if (alength > nelem) { + undefd = INDEFD + undefr = INDEFR + undefi = INDEFI + undefs = INDEFS + do i = nelem+1, alength { + $if (datatype == c) + call tbaptt (otp, ocp, orow, "", maxch, i, 1) + $endif + $if (datatype == b) + call tbaptb (otp, ocp, orow, false, i, 1) + $endif + $if (datatype == dris) + call tbapt$t (otp, ocp, orow, undef$t, i, 1) + $endif + } + } +end diff --git a/pkg/utilities/nttools/threed/titable/tisetc.x b/pkg/utilities/nttools/threed/titable/tisetc.x new file mode 100644 index 00000000..38acd306 --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/tisetc.x @@ -0,0 +1,83 @@ + +# TISETC -- Set column info in new output table. +# +# +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) +# 17-Mar-97 - Revised after code review (IB) + + +procedure tisetc (cpo, newcpo, ncpo, nscalar, itp, otp, colname, colunits, + colfmt, csize, template) + +pointer cpo # i: array of column descriptors +pointer newcpo # io: new array of column descriptors +int ncpo # i: number of columns matched by selector +int nscalar # i: number of scalar columns +char colname[ARB] # i: work array for column names +char colunits[ARB] # i: work array for column units +char colfmt[ARB] # i: work array for column format +pointer itp,otp # io: template and output table descriptors +int csize # i: cell size in output table +bool template # i: is there a template ? +#-- +pointer ocp +int i, j, colnum, ntot +int datatype, lendata, lenfmt + +errchk tihdec + +pointer tcs_column() +int tihmax() +bool tihdec() + +begin + # First copy column information from template/input + # table into output table. + do i = 1, ncpo { + ocp = tcs_column (Memi[cpo+i-1]) + if (!template) { + + # Template wasn't supplied; copy column info from 2-D + # input table into 3-D output table, taking care of + # resetting the array size. + call tbcinf (ocp, colnum, colname, colunits, colfmt, + datatype, lendata, lenfmt) + if (lendata > 1) + call error (1, "Input table has array element !") + call tbcdef (otp, ocp, colname, colunits, colfmt, + datatype, csize, 1) + } else { + + # Copy with same array size configuration, since + # template is supposedly a 3-D table. + call tbcinf (ocp, colnum, colname, colunits, colfmt, + datatype, lendata, lenfmt) + call tbcdef (otp, ocp, colname, colunits, colfmt, + datatype, lendata, 1) + } + + # Save column pointer. + Memi[newcpo+i-1] = ocp + } + + # If header-stored scalars exist, define new columns for them. + if (nscalar > 0) { + ntot = tihmax (itp) + i = ncpo + do j = 1, ntot { + if (tihdec (itp, j, colname, colunits, colfmt, datatype, + lenfmt)) { + call tbcdef (otp, ocp, colname, colunits, colfmt, + datatype, 1, 1) + Memi[newcpo+i] = ocp + i = i + 1 + } + } + } +end + diff --git a/pkg/utilities/nttools/threed/titable/titable.x b/pkg/utilities/nttools/threed/titable/titable.x new file mode 100644 index 00000000..476f00ef --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/titable.x @@ -0,0 +1,83 @@ +include + +# TITABLE -- Insert 2D tables into 3D table rows. +# +# Input tables are given by a filename template list. All row/column +# selection on input tables is performed by bracket-enclosed selectors +# appended to the file name. The output is a 3-D table with no row/column +# selectors. +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) +# 17-Mar-97 - Revised after code review (IB) +# 8-Apr-02 - Remove the unused strings for error messages (P. Hodge) +# 8-Dec-03 - Use tbtacc() instead of access() to test for a new table; +# use mfree instead of tcs_close for cpo. + + +procedure t_titable() + +char tablist[SZ_LINE] # Input table list +char output[SZ_PATHNAME] # Output table name +char template[SZ_PATHNAME] # Template table name +int row # Row where to begin insertion +bool verbose # Print operations ? +#-- +char root[SZ_FNAME] +char rowselect[SZ_FNAME] +char colselect[SZ_FNAME] +char colname[SZ_COLNAME] +char colunits[SZ_COLUNITS] +char colfmt[SZ_COLFMT] +pointer cpo +pointer otp, list +int ncpo, rowc +bool rflag + +pointer imtopen() +int clgeti(), tbtacc() +bool clgetb(), streq() + +begin + # Get task parameters. + + call clgstr ("intable", tablist, SZ_LINE) + call clgstr ("outtable", output, SZ_PATHNAME) + call clgstr ("template", template, SZ_PATHNAME) + row = clgeti ("row") + verbose = clgetb ("verbose") + + # Abort if invalid output name.. + if (streq (output, "STDOUT")) + call error (1, "Invalid output file name.") + call rdselect (output, root, rowselect, colselect, SZ_FNAME) + if (rowselect[1] != EOS || colselect[1] != EOS) + call error (1, "Sections not permitted on output table name.") + + # Open input list. + list = imtopen (tablist) + + # Open/create the output table. + if (tbtacc (output) == YES) + call tiupdate (root, otp, cpo, ncpo) + else + call tinew (template, list, root, rowselect, colselect, colname, + colunits, colfmt, otp, cpo, ncpo) + + # Initialize row counter. + rowc = row + rflag = false + if (rowc <= 0 || IS_INDEFI(rowc)) rflag = true + + # Do the insertion. + call tinsert (list, output, otp, cpo, ncpo, rowc, rflag, verbose, + rowselect, colselect, colname, colunits, colfmt) + + # Cleanup. The cpo array was allocated by tiupdate/tinew. + call mfree (cpo, TY_INT) + call tbtclo (otp) + call imtclose (list) +end diff --git a/pkg/utilities/nttools/threed/titable/tiupdate.x b/pkg/utilities/nttools/threed/titable/tiupdate.x new file mode 100644 index 00000000..ebfe9b75 --- /dev/null +++ b/pkg/utilities/nttools/threed/titable/tiupdate.x @@ -0,0 +1,39 @@ +include + +# TIUPDATE -- Opens an already existing output table for update. +# +# +# +# Revision history: +# ---------------- +# 20-Jan-97 - Task created (I.Busko) +# 17-Mar-97 - Replaced code by tbcnum call (IB) + + +procedure tiupdate (output, otp, cpo, ncpo) + +char output[ARB] # i: table name +pointer otp # o: table descriptor +pointer cpo # o: column descriptor +int ncpo # o: number of columns +#-- +int i + +errchk tbtopn + +pointer tbtopn(), tbcnum() +int tbpsta() + +begin + # Open table and get its size. + otp = tbtopn (output, READ_WRITE, NULL) + ncpo = tbpsta (otp, TBL_NCOLS) + + # Alloc column descriptor array. This + # must be freed by caller. + call malloc (cpo, ncpo, TY_INT) + + # Fill array with column info. + do i = 1, ncpo + Memi[cpo+i-1] = tbcnum (otp, i) +end diff --git a/pkg/utilities/nttools/threed/tscopy.par b/pkg/utilities/nttools/threed/tscopy.par new file mode 100644 index 00000000..d365da3e --- /dev/null +++ b/pkg/utilities/nttools/threed/tscopy.par @@ -0,0 +1,5 @@ +intable,s,a,"",,,"input tables" +outtable,s,a,"",,,"output tables or directory" +verbose,b,h,yes,,,"print operations performed?" +version,s,h,"test",,, +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/threed/tscopy/mkpkg b/pkg/utilities/nttools/threed/tscopy/mkpkg new file mode 100644 index 00000000..21136d98 --- /dev/null +++ b/pkg/utilities/nttools/threed/tscopy/mkpkg @@ -0,0 +1,14 @@ +# Update the tcopy application code in the threed package library. +# Author: I.Busko, 21-Nov-1996 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + tscopy.x + tcpyone.x + tcpyrow.x + ; + diff --git a/pkg/utilities/nttools/threed/tscopy/tbracket.x b/pkg/utilities/nttools/threed/tscopy/tbracket.x new file mode 100644 index 00000000..5c9364c4 --- /dev/null +++ b/pkg/utilities/nttools/threed/tscopy/tbracket.x @@ -0,0 +1,105 @@ +#* HISTORY * +#* B.Simon 07-Nov-94 original + +# TBRACKET -- Break a table name into bracket delimeted substrings + +procedure tbracket (table, root, rowselect, colselect, maxch) + +char table[ARB] # i: Table name +char root[ARB] # o: Name minus bracketed sections +char rowselect[ARB] # o: Row selector section +char colselect[ARB] # o: Column selector section +int maxch # i: Maximum length of output strings +#-- +bool found +char eq +int ic, nc + +data eq / '=' / + +errchk tsplitter +bool tsplitter() +int stridx() + +begin + # Search for the first unescaped bracket + + for (ic = 1; table[ic] != EOS; ic = ic + 1) { + if (table[ic] == '\\' && table[ic+1] != EOS) { + ic = ic + 1 + } else if (table[ic] == '['){ + break + } + } + + nc = min (ic-1, maxch) + call strcpy (table, root, nc) + + # Get bracketed sections from table name. If there is only + # a single section, disambiguate by looking for an equals + # sign, which indicates a row selector. + + found = tsplitter (table, ic, rowselect, maxch) + + if (! tsplitter (table, ic, colselect, maxch)) { + if (stridx (eq, rowselect) == 0) { + call strcpy (rowselect, colselect, maxch) + rowselect[1] = EOS + } + } + +end + +# TSPLITTER -- Splits table filename into sections + +bool procedure tsplitter (table, ic, section, maxch) + +char table[ARB] # i: table name +int ic # u: index to char within name +char section[ARB] # o: section extracted from name +int maxch # i: maximum length of section +#-- +int jc, level +pointer sp, errmsg + +string badsect "No closing bracket (%s)" + +begin + if (table[ic] != '[') { + section[1] = EOS + return (false) + } else { + level = 1 + ic = ic + 1 + } + + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + jc = 1 + while (level > 0 && table[ic] != EOS) { + if (table[ic] == '[' && table[ic-1] != '\\') { + level = level + 1 + } else if (table[ic] == ']' && table[ic-1] != '\\') { + level = level - 1 + } + + if (level > 0 && jc <= maxch) { + section[jc] = table[ic] + jc = jc + 1 + } + + ic = ic + 1 + } + + section[jc] = EOS + + if (level > 0) { + call sprintf (Memc[errmsg], SZ_LINE, badsect) + call pargstr (table) + call error (1, Memc[errmsg]) + } + + call sfree (sp) + return (true) +end diff --git a/pkg/utilities/nttools/threed/tscopy/tcpyone.x b/pkg/utilities/nttools/threed/tscopy/tcpyone.x new file mode 100644 index 00000000..23c86316 --- /dev/null +++ b/pkg/utilities/nttools/threed/tscopy/tcpyone.x @@ -0,0 +1,141 @@ +include + +#* HISTORY * +#* B.Simon 07-Nov-1994 original +# Phil Hodge 8-Apr-1999 call tbfpri + +# TCPYONE -- Copy a single table to the output table + +procedure tcpyone (input, output) + +char input[ARB] # i: input table name +char output[ARB] # i: output table name +#-- +int numrow, numcol, numptr, type, iptr, irow, jrow +int colnum, datatype, lendata, lenfmt +int phu_copied # returned by tbfpri and ignored +pointer sp, root, extend, rowselect, colselect, colname, colunits, colfmt +pointer errmsg, icp, ocp, itp, otp, colptr, newcol, pcode + +string nosect "Sections not permitted on output table name (%s)" +string nocols "Column names not found (%s)" + +errchk tbfpri, tbtopn, tctexp, tbracket, trsopen, trseval + +bool trseval(), streq() +int tbpsta(), tcs_totsize() +pointer tbtopn(), tcs_column, trsopen() + +begin + # Allocate memory for temporary strings + + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (extend, SZ_FNAME, TY_CHAR) + call salloc (rowselect, SZ_FNAME, TY_CHAR) + call salloc (colselect, SZ_FNAME, TY_CHAR) + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (colunits, SZ_COLUNITS, TY_CHAR) + call salloc (colfmt, SZ_COLFMT, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Check output table name for sections + +# call getsects (output, Memc[root], Memc[extend], Memc[rowselect], +# Memc[colselect], SZ_FNAME) + +call rdselect (output, Memc[root], Memc[rowselect], Memc[colselect], SZ_FNAME) + + if (Memc[rowselect] != EOS || Memc[colselect] != EOS) { + call sprintf (Memc[errmsg], SZ_LINE, nosect) + call pargstr (output) + call error (1, Memc[errmsg]) + } + + # Break input file names into bracketed sections + +# call getsects (input, Memc[root], Memc[extend], Memc[rowselect], +# Memc[colselect], SZ_FNAME) + +call rdselect (input, Memc[root], Memc[rowselect], Memc[colselect], SZ_FNAME) + + if (Memc[rowselect] == EOS && Memc[colselect] == EOS) { + # Perform straight file copy if no sections on input name + + call tbfpri (input, output, phu_copied) + call tbtcpy (input, output) + + } else { + # Open the tables and set output table type + +# call strcat (Memc[extend], Memc[root], SZ_FNAME) + + itp = tbtopn (Memc[root], READ_ONLY, NULL) + call tbfpri (Memc[root], output, phu_copied) + otp = tbtopn (output, NEW_FILE, NULL) + + type = tbpsta (itp, TBL_WHTYPE) + # Support for ASCII output (11/20/96, IB) + if (streq (output, "STDOUT")) + type = TBL_TYPE_TEXT + call tbpset (otp, TBL_WHTYPE, type) + + # Create an array of column pointers from the column template + + numrow = tbpsta (itp, TBL_NROWS) + numcol = tbpsta (itp, TBL_NCOLS) + + call salloc (colptr, numcol, TY_INT) + call salloc (newcol, numcol, TY_INT) + + call tcs_open (itp, Memc[colselect], Memi[colptr], numptr, numcol) + + # Take an error exit if no columns were matched + + if (numptr == 0) { + call sprintf (Memc[errmsg], SZ_LINE, nocols) + call pargstr (input) + call error (1, Memc[errmsg]) + } + + # Copy column information from the input table to the output table + + do iptr = 1, numptr { + icp = tcs_column (Memi[colptr+iptr-1]) + call tbcinf (icp, colnum, Memc[colname], Memc[colunits], + Memc[colfmt], datatype, lendata, lenfmt) + + if (lendata > 1) + lendata = tcs_totsize (Memi[colptr+iptr-1]) + + call tbcdef (otp, ocp, Memc[colname], Memc[colunits], + Memc[colfmt], datatype, lendata, 1) + Memi[newcol+iptr-1] = ocp + } + + # Copy header keywords + + call tbtcre (otp) + call tbhcal (itp, otp) + + # Copy selected rows from input to output table + + jrow = 1 + pcode = trsopen (itp, Memc[rowselect]) + + do irow = 1, numrow { + if (trseval (itp, irow, pcode)) { + call tcpyrow (itp, otp, Memi[colptr], Memi[newcol], + irow, jrow, numptr) + jrow = jrow + 1 + } + } + + call trsclose (pcode) + call tcs_close (Memi[colptr], numptr) + call tbtclo (itp) + call tbtclo (otp) + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/threed/tscopy/tcpyrow.x b/pkg/utilities/nttools/threed/tscopy/tcpyrow.x new file mode 100644 index 00000000..3eeb8c99 --- /dev/null +++ b/pkg/utilities/nttools/threed/tscopy/tcpyrow.x @@ -0,0 +1,79 @@ +include + +# TCPYROW -- Copy a single row from the input to output table + +procedure tcpyrow (itp, otp, icp, ocp, irow, orow, ncols) + +pointer itp # i: pointer to descriptor of input table +pointer otp # i: pointer to descriptor of output table +pointer icp[ncols] # i: array of pointers for input columns +pointer ocp[ncols] # i: array of pointers for output columns +int irow # i: row number in input table +int orow # i: row number in output table +int ncols # i: number of columns to be copied +#-- +int icol, dlen, dtype, maxch, nbuf +pointer sp, buf, errmsg, colname + +string badtype "Unsupported column data type (%s)" + +int tcs_intinfo(), tcs_totsize() + +begin + do icol = 1, ncols { + # Determine the length and datatype of the table column + # and allocate a buffer to match + + dlen = tcs_totsize (icp[icol]) + dtype = tcs_intinfo (icp[icol], TBL_COL_DATATYPE) + + maxch = 1 + if (dtype < 0) { + maxch = - dtype + dtype = TY_CHAR + } + + call smark (sp) + call salloc (buf, dlen*(maxch + 1), dtype) + + # Read the data from the input table and write it + # to the output table + + switch (dtype) { + case TY_BOOL: + call tcs_rdaryb (itp, icp[icol], irow, dlen, nbuf, Memb[buf]) + call tbaptb (otp, ocp[icol], orow, Memb[buf], 1, nbuf) + case TY_CHAR: + call tcs_rdaryt (itp, icp[icol], irow, maxch, dlen, + nbuf, Memc[buf]) + call tbaptt (otp, ocp[icol], orow, Memc[buf], maxch, 1, nbuf) + case TY_SHORT: + call tcs_rdarys (itp, icp[icol], irow, dlen, nbuf, Mems[buf]) + call tbapts (otp, ocp[icol], orow, Mems[buf], 1, nbuf) + case TY_INT, TY_LONG: + call tcs_rdaryi (itp, icp[icol], irow, dlen, nbuf, Memi[buf]) + call tbapti (otp, ocp[icol], orow, Memi[buf], 1, nbuf) + case TY_REAL: + call tcs_rdaryr (itp, icp[icol], irow, dlen, nbuf, Memr[buf]) + call tbaptr (otp, ocp[icol], orow, Memr[buf], 1, nbuf) + case TY_DOUBLE: + call tcs_rdaryd (itp, icp[icol], irow, dlen, nbuf, Memd[buf]) + call tbaptd (otp, ocp[icol], orow, Memd[buf], 1, nbuf) + default: + # Unsupported type, write error message + + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + call tcs_txtinfo (icp[icol], TBL_COL_NAME, + Memc[colname], SZ_COLNAME) + + call sprintf (Memc[errmsg], SZ_LINE, badtype) + call pargstr (Memc[colname]) + + call error (1, Memc[errmsg]) + } + + call sfree (sp) + } +end diff --git a/pkg/utilities/nttools/threed/tscopy/tscopy.x b/pkg/utilities/nttools/threed/tscopy/tscopy.x new file mode 100644 index 00000000..30629f6c --- /dev/null +++ b/pkg/utilities/nttools/threed/tscopy/tscopy.x @@ -0,0 +1,110 @@ +include + +# tcopy -- Copy table(s) + +# The input tables are given by an filename template list. The output +# is either a matching list of tables or a directory. The number of +# input tables may be either one or match the number of output tables. +# This is based on the t_imcopy procedure. +# +# Phil Hodge, 21-Aug-87 Task created. +# Phil Hodge, 7-Sep-88 Change parameter names for tables. +# Phil Hodge, 28-Dec-89 Use iferr with call to tbtcpy. +# Phil Hodge, 26-Mar-92 Remove calls to tbtext. +# B.Simon, 04-Nov-94 Replace call to tbtcpy with tcpyone +# I.Busko, 20-Nov-95 Add support for ASCII output. + +procedure t_tcopy() + +char tablist1[SZ_LINE] # Input table list +char tablist2[SZ_LINE] # Output table list +bool verbose # Print operations? + +char table1[SZ_PATHNAME] # Input table name +char table2[SZ_PATHNAME] # Output table name +char dirname1[SZ_PATHNAME] # Directory name +char dirname2[SZ_PATHNAME] # Directory name + +int list1, list2, root_len +pointer sp + +int imtopen(), imtgetim(), imtlen() +int fnldir(), isdirectory() +bool clgetb(), streq() + +begin + # Get input and output table template lists. + + call clgstr ("intable", tablist1, SZ_LINE) + call clgstr ("outtable", tablist2, SZ_LINE) + verbose = clgetb ("verbose") + + # Check if the output string is a directory. + + if (isdirectory (tablist2, dirname2, SZ_PATHNAME) > 0 && + !streq (tablist2, "STDOUT")) { + list1 = imtopen (tablist1) + while (imtgetim (list1, table1, SZ_PATHNAME) != EOF) { + call smark (sp) + + # Place the input table name without a directory in + # string dirname1. + + call get_root (table1, table2, SZ_PATHNAME) + root_len = fnldir (table2, dirname1, SZ_PATHNAME) + call strcpy (table2[root_len + 1], dirname1, SZ_PATHNAME) + + call strcpy (dirname2, table2, SZ_PATHNAME) + call strcat (dirname1, table2, SZ_PATHNAME) + + if (verbose) { + call eprintf ("%s -> %s\n") + call pargstr (table1) + call pargstr (table2) + } + iferr (call tcpyone (table1, table2)) + call erract (EA_WARN) + + call sfree (sp) + } + call imtclose (list1) + + } else { + # Expand the input and output table lists. + + list1 = imtopen (tablist1) + list2 = imtopen (tablist2) + + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (1, "Number of input and output tables not the same") + } + + # Copy each table. + + while ((imtgetim (list1, table1, SZ_PATHNAME) != EOF) && + (imtgetim (list2, table2, SZ_PATHNAME) != EOF)) { + + call smark (sp) + + if (streq (table1, table2)) { + call eprintf ("can't copy table to itself: %s\n") + call pargstr (table1) + next + } + if (verbose) { + call eprintf ("%s -> %s\n") + call pargstr (table1) + call pargstr (table2) + } + iferr (call tcpyone (table1, table2)) + call erract (EA_WARN) + + call sfree (sp) + } + + call imtclose (list1) + call imtclose (list2) + } +end diff --git a/pkg/utilities/nttools/threed/tximage.par b/pkg/utilities/nttools/threed/tximage.par new file mode 100644 index 00000000..e27bebd5 --- /dev/null +++ b/pkg/utilities/nttools/threed/tximage.par @@ -0,0 +1,5 @@ +intable,s,a,"",,,">Input tables" +output,s,a,"",,,">Output images or directory" +verbose,b,h,yes,,,">Print operations performed ?" +version,s,h,"03Jan97",,, +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/threed/tximage/mkpkg b/pkg/utilities/nttools/threed/tximage/mkpkg new file mode 100644 index 00000000..bc108e8a --- /dev/null +++ b/pkg/utilities/nttools/threed/tximage/mkpkg @@ -0,0 +1,15 @@ +# Update the tximage application code in the threed package library. +# Author: I.Busko, 26-Nov-1996 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + tximage.x + txione.x + txicpy.x + txihc.x + ; + diff --git a/pkg/utilities/nttools/threed/tximage/txicpy.x b/pkg/utilities/nttools/threed/tximage/txicpy.x new file mode 100644 index 00000000..1428ee9e --- /dev/null +++ b/pkg/utilities/nttools/threed/tximage/txicpy.x @@ -0,0 +1,61 @@ +include + +# TXICPY -- Copy data from single row and column in 3D table to +# 1-D image. +# +# +# +# +# Revision history: +# ---------------- +# +# 26-Nov-96 - Task created (I.Busko) + +procedure txicpy (itp, im, irow, icp, datatype, size) + +pointer itp # i: pointer to descriptor of input table +pointer im # i: pointer to output image +int irow # i: row in input table +pointer icp # i: array of pointers for input columns +int datatype # i: data type +int size # i: array size +#-- +int nbuf +pointer sp, bufin, bufout, errmsg, colname + +string badtype "Unsupported column data type (%s)" + +pointer impl1s(), impl1i(), impl1r(), impl1d() +begin + call smark (sp) + call salloc (bufin, size, datatype) + + switch (datatype) { + case TY_SHORT: + call tcs_rdarys (itp, icp, irow, size, nbuf, Mems[bufin]) + bufout = impl1s (im) + call amovs (Mems[bufin], Mems[bufout], size) + case TY_INT,TY_LONG: + call tcs_rdaryi (itp, icp, irow, size, nbuf, Memi[bufin]) + bufout = impl1i (im) + call amovi (Memi[bufin], Memi[bufout], size) + case TY_REAL: + call tcs_rdaryr (itp, icp, irow, size, nbuf, Memr[bufin]) + bufout = impl1r (im) + call amovr (Memr[bufin], Memr[bufout], size) + case TY_DOUBLE: + call tcs_rdaryd (itp, icp, irow, size, nbuf, Memd[bufin]) + bufout = impl1d (im) + call amovd (Memd[bufin], Memd[bufout], size) + default: + # Unsupported type, write error message + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + call tcs_txtinfo (icp, TBL_COL_NAME, Memc[colname], SZ_COLNAME) + call sprintf (Memc[errmsg], SZ_LINE, badtype) + call pargstr (Memc[colname]) + call error (1, Memc[errmsg]) + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/threed/tximage/txihc.x b/pkg/utilities/nttools/threed/tximage/txihc.x new file mode 100644 index 00000000..0f546b43 --- /dev/null +++ b/pkg/utilities/nttools/threed/tximage/txihc.x @@ -0,0 +1,53 @@ +# +# TXIHC -- Write basic column info into image header. +# +# +# +# +# Revision history: +# ---------------- +# +# 26-Nov-96 - Task created (I.Busko) +# 03-Jan-97 - Revised after code review (IB) + + +procedure txihc (im, colnum, colname, colunits, colfmt, lenfmt) + +pointer im # i: pointer to image +int colnum # i: column number in input table +char colname[ARB] # i: column name +char colunits[ARB] # i: column units +char colfmt[ARB] # i: column format +int lenfmt # i: length of format string +#-- +pointer sp, cu, cf, text + +begin + call smark (sp) + call salloc (text, SZ_LINE, TY_CHAR) + call salloc (cu, SZ_LINE, TY_CHAR) + call salloc (cf, SZ_LINE, TY_CHAR) + + # Empty units or format string are encoded as "default". + if (colunits[1] == EOS) + call strcpy ("default", Memc[cu], SZ_LINE) + else + call strcpy (colunits, Memc[cu], SZ_LINE) + if (colfmt[1] == EOS) + call strcpy ("default", Memc[cf], SZ_LINE) + else + call strcpy (colfmt, Memc[cf], SZ_LINE) + + # Assemble keyword value. + call sprintf (Memc[text], SZ_LINE, "%d %s %s %s %d") + call pargi (colnum) + call pargstr (colname) + call pargstr (Memc[cu]) + call pargstr (Memc[cf]) + call pargi (lenfmt) + + # Write keyword into header. + call imastr (im, "COLDATA", Memc[text]) + call sfree (sp) +end + diff --git a/pkg/utilities/nttools/threed/tximage/tximage.x b/pkg/utilities/nttools/threed/tximage/tximage.x new file mode 100644 index 00000000..c8575950 --- /dev/null +++ b/pkg/utilities/nttools/threed/tximage/tximage.x @@ -0,0 +1,117 @@ +include + +# TXIMAGE -- Extract image from 3D table row. + +# Input tables are given by a filename template list. All row/column +# selection on input tables is performed by bracket-enclosed selectors +# appended to the file name. The output is either a matching list of +# images or a directory. Since one input table specification can generate +# multiple output images, a naming scheme for these is defined as follows: +# +# - if output name is a directory: +# output image names are built from input table names appended with +# a _rXXX suffix, where XXX is the row number in the input file +# where the data comes from. +# +# - if output image name comes from a paired root file name list: +# same suffixing scheme as above, but using the root file name +# extracted from the list. +# +# - if only one row is selected: +# no suffixing takes place. +# +# +# This code is a re-use of B.Simon's 04-Nov-94 version of tcopy. +# +# +# +# Revision history: +# ---------------- +# +# 26-Nov-96 - Task created (I.Busko) +# 03-Jan-97 - Revised after code review (IB) + + +procedure t_tximage() + +char tablist1[SZ_LINE] # Input table list +char imlist2[SZ_LINE] # Output image list +bool verbose # Print operations ? + +char table1[SZ_PATHNAME] # Input table name +char image2[SZ_PATHNAME] # Output table name +char rootname[SZ_PATHNAME] # Root name +char dirname[SZ_PATHNAME] # Directory name + +int list1, list2, root_len +pointer sp + +int imtopen(), imtgetim(), imtlen() +int fnldir(), isdirectory() +bool clgetb(), streq() + +begin + # Get input and output table template lists. + + call clgstr ("intable", tablist1, SZ_LINE) + call clgstr ("output", imlist2, SZ_LINE) + verbose = clgetb ("verbose") + + # Check if the output string is a directory. + + if (isdirectory (imlist2, dirname, SZ_PATHNAME) > 0) { + list1 = imtopen (tablist1) + while (imtgetim (list1, table1, SZ_PATHNAME) != EOF) { + call smark (sp) + + # Place the input table name without a directory in + # string rootname. + + call get_root (table1, image2, SZ_PATHNAME) + root_len = fnldir (image2, rootname, SZ_PATHNAME) + call strcpy (image2[root_len + 1], rootname, SZ_PATHNAME) + + call strcpy (dirname, image2, SZ_PATHNAME) + call strcat (rootname, image2, SZ_PATHNAME) + + iferr (call txione (table1, image2, verbose)) + call erract (EA_WARN) + + call sfree (sp) + } + call imtclose (list1) + + } else { + # Expand the input and output table lists. + + list1 = imtopen (tablist1) + list2 = imtopen (imlist2) + + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (1, "Number of input and output files not the same") + } + + # Expand each table. + + while ((imtgetim (list1, table1, SZ_PATHNAME) != EOF) && + (imtgetim (list2, image2, SZ_PATHNAME) != EOF)) { + + call smark (sp) + + if (streq (table1, image2)) { + call eprintf ("can't expand table to itself: %s\n") + call pargstr (table1) + next + } + iferr (call txione (table1, image2, verbose)) + call erract (EA_WARN) + + call sfree (sp) + } + + call imtclose (list1) + call imtclose (list2) + } +end diff --git a/pkg/utilities/nttools/threed/tximage/txione.x b/pkg/utilities/nttools/threed/tximage/txione.x new file mode 100644 index 00000000..fa03714d --- /dev/null +++ b/pkg/utilities/nttools/threed/tximage/txione.x @@ -0,0 +1,214 @@ +include +include + +# TXIONE -- Extract images from a single input 3D table. +# +# +# +# This code is adapted from B.Simon's 04-Nov-94 version of tcopy. +# +# +# Revision history: +# ---------------- +# +# 22-Nov-96 - Task created (I.Busko) +# 16-Dec-96 - Add ORIG_ROW keyword (IB). +# 03-Jan-97 - Revised after code review (IB) +# 17-Mar-97 - Added selrows call (IB) +# 8-Apr-02 - Remove the call to whatfile (P. Hodge) + + +procedure txione (input, output, verbose) + +char input[ARB] # i: input table name +char output[ARB] # i: output table name +bool verbose # i: print operations ? +#-- +int numrow, numcol, numptr, irow, nrows +int colnum, datatype, lendata, lenfmt +pointer sp, root, extend, rowselect, colselect, colname, colunits, colfmt +pointer errmsg, icp, itp, im, colptr, pcode +pointer newname +bool suffix + +string noarray "No valid image data in %s" +string nocols "Column name not found (%s)" +string manycols "Too many columns (%s)" + +errchk tbtopn, trsopen, trseval + +bool trseval() +int tbpsta(), tcs_totsize(), selrows() +pointer tbtopn(), tcs_column, trsopen(), immap() + +begin + # Allocate memory for temporary strings. + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (newname, SZ_FNAME, TY_CHAR) + call salloc (extend, SZ_FNAME, TY_CHAR) + call salloc (rowselect, SZ_FNAME, TY_CHAR) + call salloc (colselect, SZ_FNAME, TY_CHAR) + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (colunits, SZ_COLUNITS, TY_CHAR) + call salloc (colfmt, SZ_COLFMT, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Break input file name into bracketed selectors. + call rdselect (input, Memc[root], Memc[rowselect], + Memc[colselect], SZ_FNAME) + + # Open input table and get some info about it. + itp = tbtopn (Memc[root], READ_ONLY, NULL) + numrow = tbpsta (itp, TBL_NROWS) + numcol = tbpsta (itp, TBL_NCOLS) + + # Find how many rows were requested by row selector. + # If only one, turn off suffixing. + nrows = selrows (itp, Memc[rowselect]) + if (nrows == 1) + suffix = false + else + suffix = true + + # Create array of column pointers from column selector. + # This is necessary to avoid segv in case more than one + # column selector is passed to the task. + call malloc (colptr, numcol, TY_INT) + call tcs_open (itp, Memc[colselect], Memi[colptr], numptr, numcol) + + # Take an error exit if either no columns were matched or + # more than one column was matched. + if (numptr == 0) { + call sprintf (Memc[errmsg], SZ_LINE, nocols) + call pargstr (input) + call error (1, Memc[errmsg]) + } else if (numptr != 1) { + call sprintf (Memc[errmsg], SZ_LINE, manycols) + call pargstr (input) + call error (1, Memc[errmsg]) + } + + # Loop over selected rows on input table, + # creating an image for each row. + pcode = trsopen (itp, Memc[rowselect]) + do irow = 1, numrow { + if (trseval (itp, irow, pcode)) { + + # Append suffix to output name. + if (suffix) + call txisuff (output, Memc[newname], irow) + else + call strcpy (output, Memc[newname], SZ_FNAME) + + if (verbose) { + call eprintf ("%s row=%d -> %s\n") + call pargstr (input) + call pargi (irow) + call pargstr (Memc[newname]) + } + + # Get column information. + icp = tcs_column (Memi[colptr]) + call tbcinf (icp, colnum, Memc[colname], Memc[colunits], + Memc[colfmt], datatype, lendata, lenfmt) + + # Take error exit if scalar or invalid type. + if ((lendata < 2) || (datatype < 0) || (datatype == TY_BOOL)){ + call sprintf (Memc[errmsg], SZ_LINE, noarray) + call pargstr (input) + call error (1, Memc[errmsg]) + } + + # Open output image + im = immap (Memc[newname], NEW_IMAGE, NULL) + IM_NDIM(im) = 1 + + # Copy array to image. + IM_LEN(im,1) = tcs_totsize (Memi[colptr]) + IM_PIXTYPE(im) = datatype + call txicpy (itp, im, irow, Memi[colptr], datatype, + IM_LEN(im,1)) + + # Write column data into header. + call txihc (im, colnum, Memc[colname], Memc[colunits], + Memc[colfmt], lenfmt) + + # Write row number into header. + call imaddi (im, "ORIG_ROW", irow) + + # Close output. + call imunmap (im) + } + } + + # Free memory associated with columns. + call tcs_close (Memi[colptr], numptr) + call mfree (colptr, TY_INT) + + # Close row selector structure and input table. + call trsclose (pcode) + call tbtclo (itp) + + call sfree (sp) +end + + + + +# Appends sufix to output image name. + +procedure txisuff (filename, newname, row) + +char filename[ARB] # i: output image name +char newname[ARB] # o: output image name with suffix +int row # i: row number + +pointer sp, ext, suffix +int dot, i, j + +int strcmp(), strldxs(), strlen() + +begin + call smark (sp) + call salloc (suffix, SZ_LINE, TY_CHAR) + call salloc (ext, SZ_LINE, TY_CHAR) + + # Get rid of any appendages except the extension. + call imgcluster (filename, newname, SZ_FNAME) + + # Valid extensions are .??h, .fit and .fits + # Everything else is part of the root file name. + + # Detect extension. + Memc[ext] = EOS + dot = strldxs (".", newname) + if (dot != 0) { + i = dot + j = 0 + while (newname[i] != EOS) { + Memc[ext+j] = newname[i] + j = j + 1 + i = i + 1 + } + Memc[ext+j] = EOS + } + + # If valid extension, remove it from name. + if ( ((strlen (Memc[ext]) == 4) && (Memc[ext+3] == 'h')) || + (strcmp (Memc[ext], ".fit") == 0) || + (strcmp (Memc[ext], ".fits") == 0) ) + newname[dot] = EOS + else + Memc[ext] = EOS + + # Build suffix. + call sprintf (Memc[suffix], SZ_LINE, "_r%04d") + call pargi (row) + + # Append suffix and extension to root name. + call strcat (Memc[suffix], newname, SZ_FNAME) + call strcat (Memc[ext], newname, SZ_FNAME) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/threed/txtable.par b/pkg/utilities/nttools/threed/txtable.par new file mode 100644 index 00000000..5f784362 --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable.par @@ -0,0 +1,6 @@ +intable,s,a,"",,,"Input tables" +outtable,s,a,"",,,"Output tables or directory" +compact,b,h,yes,,,"Write scalars into header ?" +verbose,b,h,yes,,,"Print operations performed ?" +version,s,h,"7Feb2000",,, +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/threed/txtable/generic/mkpkg b/pkg/utilities/nttools/threed/txtable/generic/mkpkg new file mode 100644 index 00000000..d82c36d2 --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/generic/mkpkg @@ -0,0 +1,22 @@ +# Update the generic routines. + +default: + $checkout libpkg.a ../../ + $update libpkg.a + $checkin libpkg.a ../../ +$exit + +libpkg.a: + txtcptb.x + txtcptc.x + txtcptd.x + txtcpti.x + txtcptr.x + txtcpts.x + txthvb.x + txthvc.x + txthvd.x + txthvi.x + txthvr.x + txthvs.x + ; diff --git a/pkg/utilities/nttools/threed/txtable/generic/txtcptb.x b/pkg/utilities/nttools/threed/txtable/generic/txtcptb.x new file mode 100644 index 00000000..6bed2c52 --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/generic/txtcptb.x @@ -0,0 +1,34 @@ +# +# TXTCPT -- Copy data to output table. If array, copy into column. +# If scalar, either write as column or write into header. +# +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-1996 - Task created (I.Busko) +# 7-Feb-2000 - For datatype = 'c', make buf an array of strings (P.Hodge) + +procedure txtcptb (otp, ocp, buf, start, nbuf, icol, compact) + +pointer otp # i: table descriptor +pointer ocp # i: column descriptor +bool buf[ARB] +int start # i: starting row in output table +int nbuf # i: number of elements to write into output +int icol # i: column number in input table +bool compact # i: write scalars as header keywords ? +#-- + +begin + if (ocp != NULL) { + + call tbcptb (otp, ocp, buf, start, nbuf) + + } else if (compact) { + + call txthvb (otp, icol, buf[1]) + } +end diff --git a/pkg/utilities/nttools/threed/txtable/generic/txtcptc.x b/pkg/utilities/nttools/threed/txtable/generic/txtcptc.x new file mode 100644 index 00000000..10cdc4cb --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/generic/txtcptc.x @@ -0,0 +1,35 @@ +# +# TXTCPT -- Copy data to output table. If array, copy into column. +# If scalar, either write as column or write into header. +# +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-1996 - Task created (I.Busko) +# 7-Feb-2000 - For datatype = 'c', make buf an array of strings (P.Hodge) + +procedure txtcptt (otp, ocp, buf, maxch, start, nbuf, icol, compact) + +pointer otp # i: table descriptor +pointer ocp # i: column descriptor +char buf[maxch,ARB] # i: array of values +int maxch # i: max length of string +int start # i: starting row in output table +int nbuf # i: number of elements to write into output +int icol # i: column number in input table +bool compact # i: write scalars as header keywords ? +#-- + +begin + if (ocp != NULL) { + + call tbcptt (otp, ocp, buf, maxch, start, nbuf) + + } else if (compact) { + + call txthvt (otp, icol, buf) + } +end diff --git a/pkg/utilities/nttools/threed/txtable/generic/txtcptd.x b/pkg/utilities/nttools/threed/txtable/generic/txtcptd.x new file mode 100644 index 00000000..3af0d7ac --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/generic/txtcptd.x @@ -0,0 +1,34 @@ +# +# TXTCPT -- Copy data to output table. If array, copy into column. +# If scalar, either write as column or write into header. +# +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-1996 - Task created (I.Busko) +# 7-Feb-2000 - For datatype = 'c', make buf an array of strings (P.Hodge) + +procedure txtcptd (otp, ocp, buf, start, nbuf, icol, compact) + +pointer otp # i: table descriptor +pointer ocp # i: column descriptor +double buf[ARB] +int start # i: starting row in output table +int nbuf # i: number of elements to write into output +int icol # i: column number in input table +bool compact # i: write scalars as header keywords ? +#-- + +begin + if (ocp != NULL) { + + call tbcptd (otp, ocp, buf, start, nbuf) + + } else if (compact) { + + call txthvd (otp, icol, buf[1]) + } +end diff --git a/pkg/utilities/nttools/threed/txtable/generic/txtcpti.x b/pkg/utilities/nttools/threed/txtable/generic/txtcpti.x new file mode 100644 index 00000000..552e1e7a --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/generic/txtcpti.x @@ -0,0 +1,34 @@ +# +# TXTCPT -- Copy data to output table. If array, copy into column. +# If scalar, either write as column or write into header. +# +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-1996 - Task created (I.Busko) +# 7-Feb-2000 - For datatype = 'c', make buf an array of strings (P.Hodge) + +procedure txtcpti (otp, ocp, buf, start, nbuf, icol, compact) + +pointer otp # i: table descriptor +pointer ocp # i: column descriptor +int buf[ARB] +int start # i: starting row in output table +int nbuf # i: number of elements to write into output +int icol # i: column number in input table +bool compact # i: write scalars as header keywords ? +#-- + +begin + if (ocp != NULL) { + + call tbcpti (otp, ocp, buf, start, nbuf) + + } else if (compact) { + + call txthvi (otp, icol, buf[1]) + } +end diff --git a/pkg/utilities/nttools/threed/txtable/generic/txtcptr.x b/pkg/utilities/nttools/threed/txtable/generic/txtcptr.x new file mode 100644 index 00000000..956bc45e --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/generic/txtcptr.x @@ -0,0 +1,34 @@ +# +# TXTCPT -- Copy data to output table. If array, copy into column. +# If scalar, either write as column or write into header. +# +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-1996 - Task created (I.Busko) +# 7-Feb-2000 - For datatype = 'c', make buf an array of strings (P.Hodge) + +procedure txtcptr (otp, ocp, buf, start, nbuf, icol, compact) + +pointer otp # i: table descriptor +pointer ocp # i: column descriptor +real buf[ARB] +int start # i: starting row in output table +int nbuf # i: number of elements to write into output +int icol # i: column number in input table +bool compact # i: write scalars as header keywords ? +#-- + +begin + if (ocp != NULL) { + + call tbcptr (otp, ocp, buf, start, nbuf) + + } else if (compact) { + + call txthvr (otp, icol, buf[1]) + } +end diff --git a/pkg/utilities/nttools/threed/txtable/generic/txtcpts.x b/pkg/utilities/nttools/threed/txtable/generic/txtcpts.x new file mode 100644 index 00000000..d8b805fa --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/generic/txtcpts.x @@ -0,0 +1,34 @@ +# +# TXTCPT -- Copy data to output table. If array, copy into column. +# If scalar, either write as column or write into header. +# +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-1996 - Task created (I.Busko) +# 7-Feb-2000 - For datatype = 'c', make buf an array of strings (P.Hodge) + +procedure txtcpts (otp, ocp, buf, start, nbuf, icol, compact) + +pointer otp # i: table descriptor +pointer ocp # i: column descriptor +short buf[ARB] +int start # i: starting row in output table +int nbuf # i: number of elements to write into output +int icol # i: column number in input table +bool compact # i: write scalars as header keywords ? +#-- + +begin + if (ocp != NULL) { + + call tbcpts (otp, ocp, buf, start, nbuf) + + } else if (compact) { + + call txthvs (otp, icol, buf[1]) + } +end diff --git a/pkg/utilities/nttools/threed/txtable/generic/txthvb.x b/pkg/utilities/nttools/threed/txtable/generic/txthvb.x new file mode 100644 index 00000000..eb7af9ad --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/generic/txthvb.x @@ -0,0 +1,30 @@ +# +# TXTHV -- Write scalar value into header. +# +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-96 - Task created (I.Busko) + +procedure txthvb (otp, col, buf) + +pointer otp # i: table descriptor +int col # i: column number in input table +bool buf +#-- +pointer keyword + +begin + # Use original column number to build keyword name. + call malloc (keyword, SZ_LINE, TY_CHAR) + call sprintf (Memc[keyword], SZ_LINE, "TCV_%03d") + call pargi (col) + + call tbhadb (otp, Memc[keyword], buf) + + call mfree (keyword, TY_CHAR) +end + diff --git a/pkg/utilities/nttools/threed/txtable/generic/txthvc.x b/pkg/utilities/nttools/threed/txtable/generic/txthvc.x new file mode 100644 index 00000000..6ffb3773 --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/generic/txthvc.x @@ -0,0 +1,30 @@ +# +# TXTHV -- Write scalar value into header. +# +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-96 - Task created (I.Busko) + +procedure txthvt (otp, col, buf) + +pointer otp # i: table descriptor +int col # i: column number in input table +char buf[ARB] # i: value to be written +#-- +pointer keyword + +begin + # Use original column number to build keyword name. + call malloc (keyword, SZ_LINE, TY_CHAR) + call sprintf (Memc[keyword], SZ_LINE, "TCV_%03d") + call pargi (col) + + call tbhadt (otp, Memc[keyword], buf) + + call mfree (keyword, TY_CHAR) +end + diff --git a/pkg/utilities/nttools/threed/txtable/generic/txthvd.x b/pkg/utilities/nttools/threed/txtable/generic/txthvd.x new file mode 100644 index 00000000..a074396a --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/generic/txthvd.x @@ -0,0 +1,30 @@ +# +# TXTHV -- Write scalar value into header. +# +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-96 - Task created (I.Busko) + +procedure txthvd (otp, col, buf) + +pointer otp # i: table descriptor +int col # i: column number in input table +double buf +#-- +pointer keyword + +begin + # Use original column number to build keyword name. + call malloc (keyword, SZ_LINE, TY_CHAR) + call sprintf (Memc[keyword], SZ_LINE, "TCV_%03d") + call pargi (col) + + call tbhadd (otp, Memc[keyword], buf) + + call mfree (keyword, TY_CHAR) +end + diff --git a/pkg/utilities/nttools/threed/txtable/generic/txthvi.x b/pkg/utilities/nttools/threed/txtable/generic/txthvi.x new file mode 100644 index 00000000..9df4ae94 --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/generic/txthvi.x @@ -0,0 +1,30 @@ +# +# TXTHV -- Write scalar value into header. +# +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-96 - Task created (I.Busko) + +procedure txthvi (otp, col, buf) + +pointer otp # i: table descriptor +int col # i: column number in input table +int buf +#-- +pointer keyword + +begin + # Use original column number to build keyword name. + call malloc (keyword, SZ_LINE, TY_CHAR) + call sprintf (Memc[keyword], SZ_LINE, "TCV_%03d") + call pargi (col) + + call tbhadi (otp, Memc[keyword], buf) + + call mfree (keyword, TY_CHAR) +end + diff --git a/pkg/utilities/nttools/threed/txtable/generic/txthvr.x b/pkg/utilities/nttools/threed/txtable/generic/txthvr.x new file mode 100644 index 00000000..17c4693e --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/generic/txthvr.x @@ -0,0 +1,30 @@ +# +# TXTHV -- Write scalar value into header. +# +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-96 - Task created (I.Busko) + +procedure txthvr (otp, col, buf) + +pointer otp # i: table descriptor +int col # i: column number in input table +real buf +#-- +pointer keyword + +begin + # Use original column number to build keyword name. + call malloc (keyword, SZ_LINE, TY_CHAR) + call sprintf (Memc[keyword], SZ_LINE, "TCV_%03d") + call pargi (col) + + call tbhadr (otp, Memc[keyword], buf) + + call mfree (keyword, TY_CHAR) +end + diff --git a/pkg/utilities/nttools/threed/txtable/generic/txthvs.x b/pkg/utilities/nttools/threed/txtable/generic/txthvs.x new file mode 100644 index 00000000..847fbceb --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/generic/txthvs.x @@ -0,0 +1,30 @@ +# +# TXTHV -- Write scalar value into header. +# +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-96 - Task created (I.Busko) + +procedure txthvs (otp, col, buf) + +pointer otp # i: table descriptor +int col # i: column number in input table +short buf +#-- +pointer keyword + +begin + # Use original column number to build keyword name. + call malloc (keyword, SZ_LINE, TY_CHAR) + call sprintf (Memc[keyword], SZ_LINE, "TCV_%03d") + call pargi (col) + + call tbhadi (otp, Memc[keyword], int(buf)) + + call mfree (keyword, TY_CHAR) +end + diff --git a/pkg/utilities/nttools/threed/txtable/mkpkg b/pkg/utilities/nttools/threed/txtable/mkpkg new file mode 100644 index 00000000..b6c5e53a --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/mkpkg @@ -0,0 +1,34 @@ +# Update the txtable application code in the threed package library. +# Author: I.Busko, 22-Nov-1996 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +# This module is called from the threed mkpkg. +generic: + $ifnfile (generic/txthvi.x) + $generic -k -p generic/ -t bcsird txthv.gx + $endif + $ifolder (generic/txthvi.x, txthv.gx) + $generic -k -p generic/ -t bcsird txthv.gx + $endif + $ifnfile (generic/txtcpti.x) + $generic -k -p generic/ -t bcsird txtcpt.gx + $endif + $ifolder (generic/txtcpti.x, txtcpt.gx) + $generic -k -p generic/ -t bcsird txtcpt.gx + $endif + ; + +libpkg.a: + @generic + txtable.x + txtone.x + txtcpy.x + txtcpyco.x + txtcpysc.x + txthc.x + ; + diff --git a/pkg/utilities/nttools/threed/txtable/txtable.x b/pkg/utilities/nttools/threed/txtable/txtable.x new file mode 100644 index 00000000..f56db247 --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/txtable.x @@ -0,0 +1,121 @@ +include + +# TXTABLE -- Extract 2D tables from 3D table rows. + +# Input tables are given by a filename template list. All row/column +# selection on input tables is performed by bracket-enclosed selectors +# appended to the file name. The output is either a matching list of +# tables or a directory. Output table names cannot have row/column +# selectors. Since one input table specification can generate multiple +# output tables, a naming scheme for these is defined as follows: +# +# - if output name is a directory: +# output table names are built from input table names appended with +# a _rXXX suffix, where XXX is the row number in the input file +# where the data comes from. +# +# - if output file name comes from a paired root file name list: +# same suffixing scheme as above, but using the root file name +# extracted from the list. +# +# - if only one row is selected: +# no suffixing takes place. +# +# +# This code is a re-use of B.Simon's 04-Nov-94 version of tcopy. +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-96 - Task created (I.Busko) +# 03-Jan-97 - Revised after code review (IB) + + +procedure t_txtable() + +char tablist1[SZ_LINE] # Input table list +char tablist2[SZ_LINE] # Output table list +bool compact # Put scalars in header ? +bool verbose # Print operations ? + +char table1[SZ_PATHNAME] # Input table name +char table2[SZ_PATHNAME] # Output table name +char rootname[SZ_PATHNAME] # Root name +char dirname[SZ_PATHNAME] # Directory name + +int list1, list2, root_len +pointer sp + +int imtopen(), imtgetim(), imtlen() +int fnldir(), isdirectory() +bool clgetb(), streq() + +begin + # Get input and output table template lists. + + call clgstr ("intable", tablist1, SZ_LINE) + call clgstr ("outtable", tablist2, SZ_LINE) + compact = clgetb ("compact") + verbose = clgetb ("verbose") + + # Check if the output string is a directory. + + if (isdirectory (tablist2, dirname, SZ_PATHNAME) > 0 && + !streq (tablist2, "STDOUT")) { + list1 = imtopen (tablist1) + while (imtgetim (list1, table1, SZ_PATHNAME) != EOF) { + call smark (sp) + + # Place the input table name without a directory in + # string rootname. + + call get_root (table1, table2, SZ_PATHNAME) + root_len = fnldir (table2, rootname, SZ_PATHNAME) + call strcpy (table2[root_len + 1], rootname, SZ_PATHNAME) + + call strcpy (dirname, table2, SZ_PATHNAME) + call strcat (rootname, table2, SZ_PATHNAME) + + iferr (call txtone (table1, table2, verbose, compact)) + call erract (EA_WARN) + + call sfree (sp) + } + call imtclose (list1) + + } else { + # Expand the input and output table lists. + + list1 = imtopen (tablist1) + list2 = imtopen (tablist2) + + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (1, "Number of input and output tables not the same") + } + + # Expand each table. + + while ((imtgetim (list1, table1, SZ_PATHNAME) != EOF) && + (imtgetim (list2, table2, SZ_PATHNAME) != EOF)) { + + call smark (sp) + + if (streq (table1, table2)) { + call eprintf ("can't expand table to itself: %s\n") + call pargstr (table1) + next + } + iferr (call txtone (table1, table2, verbose, compact)) + call erract (EA_WARN) + + call sfree (sp) + } + + call imtclose (list1) + call imtclose (list2) + } +end diff --git a/pkg/utilities/nttools/threed/txtable/txtcpt.gx b/pkg/utilities/nttools/threed/txtable/txtcpt.gx new file mode 100644 index 00000000..9a8ae930 --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/txtcpt.gx @@ -0,0 +1,53 @@ +# +# TXTCPT -- Copy data to output table. If array, copy into column. +# If scalar, either write as column or write into header. +# +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-1996 - Task created (I.Busko) +# 7-Feb-2000 - For datatype = 'c', make buf an array of strings (P.Hodge) + +$if (datatype == c) +procedure txtcptt (otp, ocp, buf, maxch, start, nbuf, icol, compact) +$else +procedure txtcpt$t (otp, ocp, buf, start, nbuf, icol, compact) +$endif + +pointer otp # i: table descriptor +pointer ocp # i: column descriptor +$if (datatype == c) +char buf[maxch,ARB] # i: array of values +$else +PIXEL buf[ARB] +$endif +$if (datatype == c) +int maxch # i: max length of string +$endif +int start # i: starting row in output table +int nbuf # i: number of elements to write into output +int icol # i: column number in input table +bool compact # i: write scalars as header keywords ? +#-- + +begin + if (ocp != NULL) { + + $if (datatype == c) + call tbcptt (otp, ocp, buf, maxch, start, nbuf) + $else + call tbcpt$t (otp, ocp, buf, start, nbuf) + $endif + + } else if (compact) { + + $if (datatype == c) + call txthvt (otp, icol, buf) + $else + call txthv$t (otp, icol, buf[1]) + $endif + } +end diff --git a/pkg/utilities/nttools/threed/txtable/txtcpy.x b/pkg/utilities/nttools/threed/txtable/txtcpy.x new file mode 100644 index 00000000..9a54898a --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/txtcpy.x @@ -0,0 +1,94 @@ +include + +# TXTCPY -- Copy data from single row in 3D table to columns +# in the output 2D table. +# +# +# This code is adapted from B.Simon's 04-Nov-94 version of tcopy. +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-96 - Task created (I.Busko) + + +procedure txtcpy (itp, otp, irow, icp, ocp, ncols, compact) + +pointer itp # i: pointer to descriptor of input table +pointer otp # i: pointer to descriptor of output table +int irow # i: row in input table +pointer icp[ncols] # i: array of pointers for input columns +pointer ocp[ncols] # i: array of pointers for output columns +int ncols # i: number of columns in input table +bool compact # i: write scalars as header keywords ? +#-- +int icol, dlen, dtype, maxlen, maxch, nbuf +pointer sp, buf, errmsg, colname + +string badtype "Unsupported column data type (%s)" + +int tcs_intinfo(), tcs_totsize() + +begin + # Number of rows in output table must match the + # largest array size in input table. + maxlen = 0 + do icol = 1, ncols { + dlen = tcs_totsize (icp[icol]) + if (dlen > maxlen) + maxlen = dlen + } + + # Main loop: process each column. + do icol = 1, ncols { + + # Determine datatype of table column + # and allocate a buffer to match. + dtype = tcs_intinfo (icp[icol], TBL_COL_DATATYPE) + maxch = 1 + if (dtype < 0) { + maxch = - dtype + dtype = TY_CHAR + } + call smark (sp) + call salloc (buf, maxlen*(maxch + 1), dtype) + + # Read data from input table and + # write it to output table. + switch (dtype) { + case TY_BOOL: + call tcs_rdaryb (itp, icp[icol], irow, maxlen, nbuf, Memb[buf]) + call txtcptb (otp, ocp[icol], Memb[buf], 1, nbuf, icol, compact) + case TY_CHAR: + call tcs_rdaryt (itp, icp[icol], irow, maxch, maxlen, + nbuf, Memc[buf]) + call txtcptt (otp, ocp[icol], Memc[buf], maxch, 1, nbuf, + icol, compact) + case TY_SHORT: + call tcs_rdarys (itp, icp[icol], irow, maxlen, nbuf, Mems[buf]) + call txtcpts (otp, ocp[icol], Mems[buf], 1, nbuf, icol, compact) + case TY_INT, TY_LONG: + call tcs_rdaryi (itp, icp[icol], irow, maxlen, nbuf, Memi[buf]) + call txtcpti (otp, ocp[icol], Memi[buf], 1, nbuf, icol, compact) + case TY_REAL: + call tcs_rdaryr (itp, icp[icol], irow, maxlen, nbuf, Memr[buf]) + call txtcptr (otp, ocp[icol], Memr[buf], 1, nbuf, icol, compact) + case TY_DOUBLE: + call tcs_rdaryd (itp, icp[icol], irow, maxlen, nbuf, Memd[buf]) + call txtcptd (otp, ocp[icol], Memd[buf], 1, nbuf, icol, compact) + default: + # Unsupported type, write error message + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + call tcs_txtinfo (icp[icol], TBL_COL_NAME, + Memc[colname], SZ_COLNAME) + call sprintf (Memc[errmsg], SZ_LINE, badtype) + call pargstr (Memc[colname]) + call error (1, Memc[errmsg]) + } + + call sfree (sp) + } +end diff --git a/pkg/utilities/nttools/threed/txtable/txtcpyco.x b/pkg/utilities/nttools/threed/txtable/txtcpyco.x new file mode 100644 index 00000000..c74943d4 --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/txtcpyco.x @@ -0,0 +1,45 @@ + +# TXTCPYCO -- Copy column information +# +# +# +# +# +# Revision history: +# ---------------- +# +# 03-Jan-97 - Implemented after code review (IB) + + +procedure txtcpyco (otp, colptr, newcol, numptr, colname, colunits, colfmt, + compact) + +pointer otp, colptr, newcol, colname, colunits, colfmt +int numptr +bool compact +#-- +pointer ocp +int iptr, colnum, datatype, lendata, lenfmt + +pointer tcs_column() + +begin + do iptr = 1, numptr { + ocp = tcs_column (Memi[colptr+iptr-1]) + call tbcinf (ocp, colnum, Memc[colname], Memc[colunits], + Memc[colfmt], datatype, lendata, lenfmt) + + # All columns in output are scalar-type ! + # Column info for input scalars depends on compact mode. + # If compact=no, just leave output column as scalar. + # If compact=yes, signal input scalar by setting column + # pointer to NULL. + if (compact && (lendata == 1)) { + Memi[newcol+iptr-1] = NULL + } else { + call tbcdef (otp, ocp, Memc[colname], Memc[colunits], + Memc[colfmt], datatype, 1, 1) + Memi[newcol+iptr-1] = ocp + } + } +end diff --git a/pkg/utilities/nttools/threed/txtable/txtcpysc.x b/pkg/utilities/nttools/threed/txtable/txtcpysc.x new file mode 100644 index 00000000..f35f7c54 --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/txtcpysc.x @@ -0,0 +1,34 @@ + +# TXTCPYSC -- Copy scalar columns in compact mode +# +# +# +# +# +# Revision history: +# ---------------- +# +# 03-Jan-97 - Implemented after code review (IB) + + +procedure txtcpysc (otp, colptr, newcol, numptr, colname, colunits, colfmt) + +pointer otp, colptr, newcol, colname, colunits, colfmt +int numptr + +pointer icp +int iptr, colnum, datatype, lendata, lenfmt + +pointer tcs_column + +begin + do iptr = 1, numptr { + if (Memi[newcol+iptr-1] == NULL) { + icp = tcs_column (Memi[colptr+iptr-1]) + call tbcinf (icp, colnum, Memc[colname], Memc[colunits], + Memc[colfmt], datatype, lendata, lenfmt) + call txthc (otp, colnum, Memc[colname], Memc[colunits], + Memc[colfmt], datatype, lenfmt) + } + } +end diff --git a/pkg/utilities/nttools/threed/txtable/txthc.x b/pkg/utilities/nttools/threed/txtable/txthc.x new file mode 100644 index 00000000..3e6f8555 --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/txthc.x @@ -0,0 +1,85 @@ +# +# TXTHC -- Write basic column info into header. +# +# +# +# +# Revision history: +# ---------------- +# +# 25-Nov-96 - Task created (I.Busko) +# 03-Jan-97 - Revised after code review (IB) + + +procedure txthc (otp, colnum, colname, colunits, colfmt, + datatype, lenfmt) + +pointer otp # i: pointer to descriptor of output table +int colnum # i: column number in input table +char colname[ARB] # i: column name +char colunits[ARB] # i: column units +char colfmt[ARB] # i: column format +int datatype # i: data type +int lenfmt # i: length of format string +#-- +pointer sp, cu, cf, keyword, text, dtype +int lenstr + +begin + call smark (sp) + call salloc (keyword, SZ_LINE, TY_CHAR) + call salloc (text, SZ_LINE, TY_CHAR) + call salloc (dtype, SZ_LINE, TY_CHAR) + call salloc (cu, SZ_LINE, TY_CHAR) + call salloc (cf, SZ_LINE, TY_CHAR) + + # Use original column number to build keyword name. + call sprintf (Memc[keyword], SZ_LINE, "TCD_%03d") + call pargi (colnum) + + # Data type is encoded as a human-readable character string. + if (datatype < 0) { + lenstr = -datatype + datatype = TY_CHAR + } + switch (datatype) { + case TY_BOOL: + call strcpy ("boolean", Memc[dtype], SZ_LINE) + case TY_SHORT: + call strcpy ("short", Memc[dtype], SZ_LINE) + case TY_INT: + call strcpy ("integer", Memc[dtype], SZ_LINE) + case TY_LONG: + call strcpy ("long", Memc[dtype], SZ_LINE) + case TY_REAL: + call strcpy ("real", Memc[dtype], SZ_LINE) + case TY_DOUBLE: + call strcpy ("double", Memc[dtype], SZ_LINE) + case TY_CHAR: + call sprintf (Memc[dtype], SZ_LINE, "character_%d") + call pargi (lenstr) + } + + # Empty units or format string are encoded as "default". + if (colunits[1] == EOS) + call strcpy ("default", Memc[cu], SZ_LINE) + else + call strcpy (colunits, Memc[cu], SZ_LINE) + if (colfmt[1] == EOS) + call strcpy ("default", Memc[cf], SZ_LINE) + else + call strcpy (colfmt, Memc[cf], SZ_LINE) + + # Assemble keyword value. + call sprintf (Memc[text], SZ_LINE, "%s %s %s %s %d") + call pargstr (colname) + call pargstr (Memc[cu]) + call pargstr (Memc[cf]) + call pargstr (Memc[dtype]) + call pargi (lenfmt) + + # Write keyword into header. + call tbhadt (otp, Memc[keyword], Memc[text]) + call sfree (sp) +end + diff --git a/pkg/utilities/nttools/threed/txtable/txthv.gx b/pkg/utilities/nttools/threed/txtable/txthv.gx new file mode 100644 index 00000000..d965f704 --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/txthv.gx @@ -0,0 +1,55 @@ +# +# TXTHV -- Write scalar value into header. +# +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-96 - Task created (I.Busko) + +$if (datatype == c) +procedure txthvt (otp, col, buf) +$else +procedure txthv$t (otp, col, buf) +$endif + +pointer otp # i: table descriptor +int col # i: column number in input table +$if (datatype == c) +char buf[ARB] # i: value to be written +$else +PIXEL buf +$endif +#-- +pointer keyword + +begin + # Use original column number to build keyword name. + call malloc (keyword, SZ_LINE, TY_CHAR) + call sprintf (Memc[keyword], SZ_LINE, "TCV_%03d") + call pargi (col) + + $if (datatype == c) + call tbhadt (otp, Memc[keyword], buf) + $endif + $if (datatype == i) + call tbhadi (otp, Memc[keyword], buf) + $endif + $if (datatype == s) + call tbhadi (otp, Memc[keyword], int(buf)) + $endif + $if (datatype == b) + call tbhadb (otp, Memc[keyword], buf) + $endif + $if (datatype == r) + call tbhadr (otp, Memc[keyword], buf) + $endif + $if (datatype == d) + call tbhadd (otp, Memc[keyword], buf) + $endif + + call mfree (keyword, TY_CHAR) +end + diff --git a/pkg/utilities/nttools/threed/txtable/txtone.x b/pkg/utilities/nttools/threed/txtable/txtone.x new file mode 100644 index 00000000..d286523d --- /dev/null +++ b/pkg/utilities/nttools/threed/txtable/txtone.x @@ -0,0 +1,227 @@ +include + +# TXTONE -- Extract 2D tables from a single input 3D table. +# +# +# This code is adapted from B.Simon's 04-Nov-94 version of tcopy. +# +# +# +# Revision history: +# ---------------- +# +# 22-Nov-1996 - Task created (I.Busko) +# 16-Dec-1996 - Add ORIG_ROW keyword (IB). +# 03-Jan-1997 - Revised after code review (IB) +# 17-Mar-1997 - Added selrows call (IB) +# 8-Apr-1999 - Call tbfpri (Phil Hodge) +# 8-Apr-2002 - Remove the call to whatfile (P. Hodge) + + +procedure txtone (input, output, verbose, compact) + +char input[ARB] # i: input table name +char output[ARB] # i: output table name +bool compact # i: put scalars in header ? +bool verbose # i: print operations ? +#-- +int numrow, numcol, numptr, type, irow, nrows +int phu_copied # set by tbfpri and ignored +pointer sp, root, extend, rowselect, colselect, colname, colunits, colfmt +pointer errmsg, itp, otp, colptr, newcol, pcode +pointer newname +bool suffix + +string nosect "Sections not permitted on output table name (%s)" +string nocols "Column names not found (%s)" + +errchk tbfpri, tbtopn, tctexp, tbracket, trsopen, trseval + +bool trseval(), streq() +int tbpsta(), selrows() +pointer tbtopn(), trsopen() + +begin + # Allocate memory for temporary strings. + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (newname, SZ_FNAME, TY_CHAR) + call salloc (extend, SZ_FNAME, TY_CHAR) + call salloc (rowselect, SZ_FNAME, TY_CHAR) + call salloc (colselect, SZ_FNAME, TY_CHAR) + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (colunits, SZ_COLUNITS, TY_CHAR) + call salloc (colfmt, SZ_COLFMT, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Selectors are forbbiden on output. + call rdselect (output, Memc[root], Memc[rowselect], + Memc[colselect], SZ_FNAME) + if (Memc[rowselect] != EOS || Memc[colselect] != EOS) { + call sprintf (Memc[errmsg], SZ_LINE, nosect) + call pargstr (output) + call error (1, Memc[errmsg]) + } + + # Break input file name into bracketed selectors. + call rdselect (input, Memc[root], Memc[rowselect], + Memc[colselect], SZ_FNAME) + + # Open input table and get some info about it. + itp = tbtopn (Memc[root], READ_ONLY, NULL) + numrow = tbpsta (itp, TBL_NROWS) + numcol = tbpsta (itp, TBL_NCOLS) + + # Find how many rows were requested by row selector. + # If only one, turn off suffixing. Also do it in case + # ASCII output was requested. + nrows = selrows (itp, Memc[rowselect]) + if (nrows == 1) + suffix = false + else + suffix = true + if (streq (output, "STDOUT")) + suffix = false + + # Create array of column pointers from column selector. + call malloc (colptr, numcol, TY_INT) + call malloc (newcol, numcol, TY_INT) + call tcs_open (itp, Memc[colselect], Memi[colptr], numptr, numcol) + + # Take an error exit if no columns were matched. + if (numptr == 0) { + call sprintf (Memc[errmsg], SZ_LINE, nocols) + call pargstr (input) + call error (1, Memc[errmsg]) + } + + # Loop over selected rows on input table, creating + # a 2D output table for each row. + pcode = trsopen (itp, Memc[rowselect]) + do irow = 1, numrow { + if (trseval (itp, irow, pcode)) { + + # Append suffix to output name. + if (suffix) + call txtsuff (output, Memc[newname], irow) + else + call strcpy (output, Memc[newname], SZ_FNAME) + + if (verbose) { + call printf ("%s row=%d -> %s\n") + call pargstr (input) + call pargi (irow) + call pargstr (Memc[newname]) + call flush (STDOUT) + } + + # Open output table and set its type. + call tbfpri (Memc[root], Memc[newname], phu_copied) + otp = tbtopn (Memc[newname], NEW_FILE, NULL) + type = tbpsta (itp, TBL_WHTYPE) + if (streq (output, "STDOUT")) # ASCII output. + type = TBL_TYPE_TEXT + call tbpset (otp, TBL_WHTYPE, type) + + # Copy column information from input to output. + call txtcpyco (otp, colptr, newcol, numptr, colname, + colunits, colfmt, compact) + + # Create table and copy header. + call tbtcre (otp) + call tbhcal (itp, otp) + + # Copy row number into header. + call tbhadi (otp, "ORIG_ROW", irow) + + # Copy scalar columns into header. + if (compact) + call txtcpysc (otp, colptr, newcol, numptr, colname, + colunits, colfmt) + + # Copy number of columns into header. This is used + # by task that reads back 2D tables into 3D format. + if (compact) + call tbhadi (otp, "TCTOTAL", numptr) + + # Copy data to output table. + call txtcpy (itp, otp, irow, Memi[colptr], Memi[newcol], + numptr, compact) + + # Close output. + call tbtclo (otp) + } + } + + # Free arrays associated with columns. + call tcs_close (Memi[colptr], numptr) + call mfree (newcol, TY_INT) + call mfree (colptr, TY_INT) + + # Close row selector structure and input table. + call trsclose (pcode) + call tbtclo (itp) + + call sfree (sp) +end + + + + +# Appends sufix to output file name. + +procedure txtsuff (filename, newname, row) + +char filename[ARB] # i: output table name +char newname[ARB] # o: output table name with suffix +int row # i: row number + +pointer sp, ext, suffix +int dot, i, j + +int strcmp(), strldxs() + +begin + call smark (sp) + call salloc (suffix, SZ_LINE, TY_CHAR) + call salloc (ext, SZ_LINE, TY_CHAR) + + # Get rid of any appendages except the extension. + call imgcluster (filename, newname, SZ_FNAME) + + # Valid extensions are .tab, .fit and .fits + # Everything else is part of the root file name. + + # Detect extension. + Memc[ext] = EOS + dot = strldxs (".", newname) + if (dot != 0) { + i = dot + j = 0 + while (newname[i] != EOS) { + Memc[ext+j] = newname[i] + j = j + 1 + i = i + 1 + } + Memc[ext+j] = EOS + } + + # If valid extension, remove it from name. + if ( (strcmp (Memc[ext], ".tab") == 0) || + (strcmp (Memc[ext], ".fit") == 0) || + (strcmp (Memc[ext], ".fits") == 0) ) + newname[dot] = EOS + else + Memc[ext] = EOS + + # Build suffix. + call sprintf (Memc[suffix], SZ_LINE, "_r%04d") + call pargi (row) + + # Append suffix and extension to root name. + call strcat (Memc[suffix], newname, SZ_FNAME) + call strcat (Memc[ext], newname, SZ_FNAME) + + call sfree (sp) +end + diff --git a/pkg/utilities/nttools/threed/x_threed.x b/pkg/utilities/nttools/threed/x_threed.x new file mode 100644 index 00000000..ed67f6b7 --- /dev/null +++ b/pkg/utilities/nttools/threed/x_threed.x @@ -0,0 +1,5 @@ +task tscopy = t_tcopy, + txtable = t_txtable, + tximage = t_tximage, + titable = t_titable, + tiimage = t_tiimage diff --git a/pkg/utilities/nttools/thselect.par b/pkg/utilities/nttools/thselect.par new file mode 100644 index 00000000..a2eb2fc4 --- /dev/null +++ b/pkg/utilities/nttools/thselect.par @@ -0,0 +1,5 @@ +table,s,a,"",,,input tables +keywords,s,a,"",,,keywords to be listed +expr,s,a,"yes",,,boolean expression governing selection +Version,s,h,"21July2000",,,"date of installation" +mode,s,h,"al" diff --git a/pkg/utilities/nttools/tinfo.par b/pkg/utilities/nttools/tinfo.par new file mode 100644 index 00000000..9f65e296 --- /dev/null +++ b/pkg/utilities/nttools/tinfo.par @@ -0,0 +1,15 @@ +# parameter file for tinfo +table,s,a,"",,,"name of table" +ttout,b,h,y,,,"display values on terminal?" +nrows,i,h,0,,,"number of rows written to table" +ncols,i,h,0,,,"number of columns defined" +npar,i,h,0,,,"number of header parameters written to table" +rowlen,r,h,0,,,"row length in units of SZ_REAL" +rowused,r,h,0,,,"amount of row length used in units of SZ_REAL" +allrows,i,h,0,,,"number of allocated rows" +maxpar,i,h,0,,,"space allocated for header parameters" +maxcols,i,h,0,,,"space allocated for column descriptors" +tbltype,s,h,"",,,"table type" +subtype,s,h,"",,,"table subtype" +tblversion,i,h,0,,,"version of software that created the table" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/tinfo/mkpkg b/pkg/utilities/nttools/tinfo/mkpkg new file mode 100644 index 00000000..dd50f0f1 --- /dev/null +++ b/pkg/utilities/nttools/tinfo/mkpkg @@ -0,0 +1,12 @@ +# Update the tinfo application code in the ttools package library +# Author: HODGE, 2-FEB-1988 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + tinfo.x + tlcol.x + ; diff --git a/pkg/utilities/nttools/tinfo/tinfo.x b/pkg/utilities/nttools/tinfo/tinfo.x new file mode 100644 index 00000000..a90fa1be --- /dev/null +++ b/pkg/utilities/nttools/tinfo/tinfo.x @@ -0,0 +1,179 @@ +include +include # used to check whether input is redirected +include + +# tinfo -- get information about a table +# This task displays such information as the number of rows and columns +# in a table. The values are also put into parameters for the task. +# +# Phil Hodge, 22-Jul-1987 Task created +# Phil Hodge, 11-Aug-1987 Delete call to tbtext. +# Phil Hodge, 28-Aug-1987 Include maxcols, change name allpar-->maxpar +# Phil Hodge, 7-Sep-1988 Change parameter name for table. +# Phil Hodge, 9-Dec-1988 Input can be a list of tables. +# Phil Hodge, 10-May-1991 Use clpopns instead of clpopnu. +# Phil Hodge, 23-Aug-1991 Change "user" to "header" in output. +# Phil Hodge, 16-Mar-1992 Include text table type. +# Phil Hodge, 26-Mar-1992 Remove call to tbtext; use tbtnam instead. +# Phil Hodge, 8-Apr-1993 Also write software version number to par file. +# Phil Hodge, 6-Aug-1993 Change "version" to "tblversion". +# Phil Hodge, 21-Dec-1994 Change rowlen and rowused from int to real. +# Phil Hodge, 1-Jul-1995 Modify for FITS tables. +# Phil Hodge, 3-Oct-1995 Modify to use tbn instead of fnt. +# Phil Hodge, 9-Jun-1999 Print table subtype, and save to new cl parameter; +# if input is redirected, set input to STDIN without getting cl param. +# Change "row" & "column" to subtypes of table type "stsdas". +# Phil Hodge, 22-Feb-2002 For image subtype, change what is printed from +# "primary header" to "image", since it can now be an image extension. + +procedure tinfo() + +pointer tlist # for list of input table names +pointer tp # pointer to table descriptor +pointer sp +pointer tname # scratch for table name +pointer ttype # scratch for table type +pointer tsubtype # scratch for table subtype +bool ttout # true if the user wants output to the terminal +int nrows # number of rows written to the table +int ncols # number of columns defined +int npar # number of header parameters written to the table +real rowlen # (r) row length (unit = SZ_REAL) +real rowused # (r) portion of row length used by the defined columns +int allrows # (c) number of rows allocated +int maxpar # space allocated for header parameters +int maxcols # space allocated for column descriptors +int tbltype # table type +int tbl_subtype # table subtype +int tblversion # version number of software that created the table +pointer tbtopn() +int tbpsta() +bool clgetb() +int fstati() +pointer tbnopenp(), tbnopen() +int tbnget() + +begin + call smark (sp) + call salloc (tname, SZ_FNAME, TY_CHAR) + call salloc (ttype, SZ_FNAME, TY_CHAR) + call salloc (tsubtype, SZ_FNAME, TY_CHAR) + Memc[ttype] = EOS + Memc[tsubtype] = EOS + + if (fstati (STDIN, F_REDIR) == YES) + tlist = tbnopen ("STDIN") + else + tlist = tbnopenp ("table") + + ttout = clgetb ("ttout") + + # Do for each table in the input list. + while (tbnget (tlist, Memc[tname], SZ_FNAME) != EOF) { + + iferr { + tp = tbtopn (Memc[tname], READ_ONLY, 0) + } then { + call eprintf ("can't open %s\n") + call pargstr (Memc[tname]) + call erract (EA_WARN) + next + } + + nrows = tbpsta (tp, TBL_NROWS) + ncols = tbpsta (tp, TBL_NCOLS) + npar = tbpsta (tp, TBL_NPAR) + rowlen = real (tbpsta (tp, TBL_ROWLEN_CHAR)) / SZ_REAL + rowused = real (tbpsta (tp, TBL_ROWLEN_CHAR_USED)) / SZ_REAL + allrows = tbpsta (tp, TBL_ALLROWS) + maxpar = tbpsta (tp, TBL_MAXPAR) + maxcols = tbpsta (tp, TBL_MAXCOLS) + tbltype = tbpsta (tp, TBL_WHTYPE) + tbl_subtype = tbpsta (tp, TBL_SUBTYPE) + tblversion = tbpsta (tp, TBL_VERSION) + + # Express the table type as a string. + if (tbltype == TBL_TYPE_S_ROW) + call strcpy ("stsdas", Memc[ttype], SZ_FNAME) + else if (tbltype == TBL_TYPE_S_COL) + call strcpy ("stsdas", Memc[ttype], SZ_FNAME) + else if (tbltype == TBL_TYPE_TEXT) + call strcpy ("text", Memc[ttype], SZ_FNAME) + else if (tbltype == TBL_TYPE_FITS) + call strcpy ("fits", Memc[ttype], SZ_FNAME) + else + call strcpy ("unknown", Memc[ttype], SZ_FNAME) + + # Express the subtype as a string. + if (tbltype == TBL_TYPE_TEXT) { + if (tbl_subtype == TBL_SUBTYPE_SIMPLE) + call strcpy ("simple", Memc[tsubtype], SZ_FNAME) + else if (tbl_subtype == TBL_SUBTYPE_EXPLICIT) + call strcpy ("explicit column definitions", + Memc[tsubtype], SZ_FNAME) + } else if (tbltype == TBL_TYPE_FITS) { + if (tbl_subtype == TBL_SUBTYPE_ASCII) + call strcpy ("ascii", Memc[tsubtype], SZ_FNAME) + else if (tbl_subtype == TBL_SUBTYPE_BINTABLE) + call strcpy ("binary", Memc[tsubtype], SZ_FNAME) + else if (tbl_subtype == TBL_SUBTYPE_IMAGE) + call strcpy ("image", Memc[tsubtype], SZ_FNAME) + } else if (tbltype == TBL_TYPE_S_ROW) { + call strcpy ("row ordered", Memc[tsubtype], SZ_FNAME) + } else if (tbltype == TBL_TYPE_S_COL) { + call strcpy ("column ordered", Memc[tsubtype], SZ_FNAME) + } else { + call strcpy ("N/A", Memc[tsubtype], SZ_FNAME) + } + + if (ttout) { + call tbtnam (tp, Memc[tname], SZ_FNAME) # get full name + call printf ("# %s\n") + call pargstr (Memc[tname]) + call printf ("%4d rows written to table\n") + call pargi (nrows) + call printf ("%4d columns defined\n") + call pargi (ncols) + call printf ("%4d header parameters written to table\n") + call pargi (npar) + if (tbltype == TBL_TYPE_S_ROW) { + call printf ("%6.1f row length in units of SZ_REAL\n") + call pargr (rowlen) + call printf ("%6.1f amount of row length used\n") + call pargr (rowused) + } else if (tbltype == TBL_TYPE_S_COL) { + call printf ("%4d rows allocated\n") + call pargi (allrows) + } + call printf ("%4d records allocated for header parameters\n") + call pargi (maxpar) + call printf ("%4d space allocated for column descriptors\n") + call pargi (maxcols) + call printf ("table type: %s") + call pargstr (Memc[ttype]) + if (tbl_subtype != TBL_SUBTYPE_SIMPLE && + tbl_subtype != TBL_SUBTYPE_BINTABLE && + tbltype != TBL_TYPE_S_ROW) { + call printf (" %s") + call pargstr (Memc[tsubtype]) + } + call printf ("\n") # after table type and subtype + } + call tbtclo (tp) + } + + call clputi ("nrows", nrows) + call clputi ("ncols", ncols) + call clputi ("npar", npar) + call clputr ("rowlen", rowlen) + call clputr ("rowused", rowused) + call clputi ("allrows", allrows) + call clputi ("maxpar", maxpar) + call clputi ("maxcols", maxcols) + call clpstr ("tbltype", Memc[ttype]) + call clpstr ("subtype", Memc[tsubtype]) + call clputi ("tblversion", tblversion) + + call tbnclose (tlist) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tinfo/tlcol.x b/pkg/utilities/nttools/tinfo/tlcol.x new file mode 100644 index 00000000..c5bc2b97 --- /dev/null +++ b/pkg/utilities/nttools/tinfo/tlcol.x @@ -0,0 +1,128 @@ +include +include # used to check whether input is redirected +include + +define T_MAXDIM 7 # maximum dimension of array +define SZ_DTYPE 29 # size of string containing column data type + +# tlcol -- list column information +# This task writes information about the columns in a table. At least +# the column names will be listed, and the data types, formats, and units +# may also be listed. The column name and units are allowed (at least +# by this program) to contain embedded blanks, in which case they will +# be printed enclosed in double quotes. +# +# Phil Hodge, 23-Jul-1987 Task created +# Phil Hodge, 11-Aug-1987 Modify for change in datatype for char string to -n +# and change in calling sequence of inquotes. +# Phil Hodge, 3-Feb-1988 Left-justify info except for print format. +# Phil Hodge, 7-Sep-1988 Change parameter name for table. +# Phil Hodge, 9-Dec-1988 Input can be a list of tables. +# Phil Hodge, 10-May-1991 Use clpopns instead of clpopnu. +# Phil Hodge, 26-Mar-1992 Remove call to tbtext; use tbtnam instead. +# Phil Hodge, 1-Apr-1993 Include short datatype. +# Phil Hodge, 6-Jun-1994 Call erract if error opening table; flush STDOUT. +# Phil Hodge, 18-Nov-1994 Print array size combined with data type; +# increase SZ_DTYPE from 9 to 29; increase width of +# field for printing data type from 6 to 8. +# Phil Hodge, 13-Jan-1995 Change calling sequence of inquotes. +# Phil Hodge, 19-Jul-1995 Add tp to calling sequence of tl_dtype. +# Phil Hodge, 3-Oct-1995 Modify to use tbn instead of fnt. +# Phil Hodge, 7-Jun-1999 If input is redirected, set input to STDIN without +# getting cl param. + +procedure tlcol() + +pointer tlist # for list of input table names +pointer tp # pointer to descriptor for input table +pointer cp # pointer to column descriptor +pointer sp +pointer tname # pointer to scratch space for table name +pointer cname, cunits, cfmt # pointers to scratch space for column info +char chartyp[SZ_DTYPE] # data type expressed as a string +int datatype # column data type +int nelem, lenfmt # length of array; width of format +int ncols # number of columns in table +int nlist # number of items to list (from one to four) +int k # loop index +int colnum # column number (ignored) +pointer tbtopn(), tbpsta(), tbcnum() +int clgeti() +int fstati() +pointer tbnopenp(), tbnopen() +int tbnget() + +begin + call smark (sp) + call salloc (tname, SZ_LINE, TY_CHAR) + call salloc (cname, SZ_LINE, TY_CHAR) + call salloc (cunits, SZ_LINE, TY_CHAR) + call salloc (cfmt, SZ_COLFMT, TY_CHAR) + + if (fstati (STDIN, F_REDIR) == YES) + tlist = tbnopen ("STDIN") + else + tlist = tbnopenp ("table") + nlist = clgeti ("nlist") + + # Do for each table in the input list. + while (tbnget (tlist, Memc[tname], SZ_LINE) != EOF) { + + iferr { + tp = tbtopn (Memc[tname], READ_ONLY, 0) + } then { + call eprintf ("# %s\n") + call pargstr (Memc[tname]) + call erract (EA_WARN) + next + } + + call tbtnam (tp, Memc[tname], SZ_LINE) # get full name + call printf ("# %s\n") + call pargstr (Memc[tname]) + + ncols = tbpsta (tp, TBL_NCOLS) + + do k = 1, ncols { + cp = tbcnum (tp, k) + call tbcinf (cp, + colnum, Memc[cname], Memc[cunits], Memc[cfmt], + datatype, nelem, lenfmt) + + # Enclose column name in quotes if it contains embedded + # or trailing blanks. + call inquotes (Memc[cname], Memc[cname], SZ_LINE, YES) + call printf ("%-16s") # but name can be longer + call pargstr (Memc[cname]) + + if (nlist > 1) { # also print data type + + # Convert integer data type code to a character string, + # and append info about array size if > 1. + call tl_dtype (tp, cp, datatype, nelem, chartyp, SZ_DTYPE) + + call printf (" %-8s") + call pargstr (chartyp) + + if (nlist > 2) { # also print format for display + call printf (" %8s") + call pargstr (Memc[cfmt]) + + if (nlist > 3) { # also print column units + # The "NO" means ignore trailing blanks. + call inquotes (Memc[cunits], Memc[cunits], + SZ_LINE, NO) + call printf (" %-16s") # but can be longer + call pargstr (Memc[cunits]) + } + } + } + call printf ("\n") # end of line for each column + } + call flush (STDOUT) + call tbtclo (tp) + } + + call tbnclose (tlist) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tintegrate.par b/pkg/utilities/nttools/tintegrate.par new file mode 100644 index 00000000..1165ac29 --- /dev/null +++ b/pkg/utilities/nttools/tintegrate.par @@ -0,0 +1,6 @@ +table,f,a,,,,"input table" +integrand,s,a,"",,,"integrand" +independent,s,a,"",,,"independent variable - integrate col1 wrt col2" +integral,r,h,0.0,,,"Result of integration" +ptsused,i,h,0,,,"Number of data points used" +mode,s,h,al diff --git a/pkg/utilities/nttools/tintegrate/mkpkg b/pkg/utilities/nttools/tintegrate/mkpkg new file mode 100644 index 00000000..cfe87a34 --- /dev/null +++ b/pkg/utilities/nttools/tintegrate/mkpkg @@ -0,0 +1,11 @@ +# Update the tintegrate application code in the ttools package library +# Author: GIARETTA, 7-DEC-1987 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + tintegrate.x + ; diff --git a/pkg/utilities/nttools/tintegrate/tintegrate.x b/pkg/utilities/nttools/tintegrate/tintegrate.x new file mode 100644 index 00000000..3f01fd67 --- /dev/null +++ b/pkg/utilities/nttools/tintegrate/tintegrate.x @@ -0,0 +1,155 @@ +include +include # to check whether input is redirected +include +include + +# T_INTEGRATE -- integrate one column of a table wrt another +# using simple trapezoid rule, ignoring INDEF values +# +# D. Giaretta, 01-Aug-1987 Original SPP version +# Phil Hodge, 7-Sep-1988 Change parameter name for table. +# Phil Hodge, 26-Jan-1996 Add option to just sum the values. +# Phil hodge, 8-Jun-1999 Set input to STDIN if redirected; +# open the table READ_ONLY, not READ_WRITE. + +procedure t_tintegrate() + +char inname[SZ_FNAME] # input table name +char col1[SZ_COLNAME] # integrand +char col2[SZ_COLNAME] # independent var. +#-- +pointer sp +pointer pt1, pt2, nullpt1, nullpt2 +pointer tp +pointer colptr1, colptr2 +int i +long numrows +long numused +long lastgood, firstgood # zero indexed +double integ +int fstati() +int tbpsta() +pointer tbtopn() +bool isblank() + +errchk tbtopn, clgstr, tbpsta, clputr, clputl + +begin + + call smark(sp) + + integ = 0.0d0 + numused = 0 + lastgood = -1 + firstgood = -1 + + if (fstati (STDIN, F_REDIR) == YES) + call strcpy ("STDIN", inname, SZ_FNAME) + else + call clgstr ("table", inname, SZ_FNAME) + + tp = tbtopn( inname, READ_ONLY, 0) + numrows = tbpsta(tp, TBL_NROWS) + + call clgstr( "integrand", col1, SZ_COLNAME) + call clgstr( "independent", col2, SZ_COLNAME) + + call tbcfnd( tp, col1, colptr1, 1) + if (colptr1 == NULL) + call error (0, "integrand not found in table") + + if (isblank (col2)) { + colptr2 = NULL + } else { + call tbcfnd( tp, col2, colptr2, 1) + if (colptr2 == NULL) + call error (0, "independent variable not found in table") + } + + # Get dependent variable values. + call salloc( pt1, numrows, TY_DOUBLE) + call salloc( nullpt1, numrows, TY_BOOL) + call tbcgtd(tp, colptr1, Memd[pt1], Memb[nullpt1], 1, numrows) + + # Get independent variable values. + if (colptr2 != NULL) { + call salloc( pt2, numrows, TY_DOUBLE) + call salloc( nullpt2, numrows, TY_BOOL) + call tbcgtd(tp, colptr2, Memd[pt2], Memb[nullpt2], 1, numrows) + } + + # Find first non-INDEF row. + if (colptr2 == NULL) { + do i = 0, numrows-1 { + if (!Memb[nullpt1+i]) { + firstgood = i + break + } + } + } else { + do i = 0, numrows-1 { + if ( !Memb[nullpt1+i] && !Memb[nullpt2+i] ) { + firstgood = i + break + } + } + } + if (firstgood == -1) { + call tbtclo (tp) + call error (1, "no data in table") + } + lastgood = firstgood + + # apply simple trapezoid rule - + # ignore INDEF values, in other words linearly interpolate + # between adjacent good values + # note also that the independent must be non-decreasing + + if (colptr2 == NULL) { + + # No independent variable; just sum the values. + numused = 0 + do i= firstgood, numrows-1 { + if ( !Memb[nullpt1+i] ) { + integ = integ + Memd[pt1+i] + lastgood = i + numused = numused + 1 + } + } + + } else { + + # Integrate with respect to an independent variable. + numused = 1 + do i= firstgood+1, numrows-1 { + if ( !Memb[nullpt1+i] && !Memb[nullpt2+i] ) { + if ( Memd[pt2+i] < Memd[pt2+lastgood] ) + call error(0, "independent variable not increasing") + integ = integ + + 0.5*(Memd[pt1+i] + Memd[pt1+lastgood]) * + (Memd[pt2+i] - Memd[pt2+lastgood]) + lastgood = i + numused = numused + 1 + } + } + } + + # output integral both as parameter and to STDOUT + # also record the number of good points used + + if (numused < 2) { + call printf (" integral = INDEF, at least 2 good points required") + call clputd ("integral", INDEFD) + } else { + call printf (" integral= %g using %d points\n") + call pargd (integ) + call pargi (numused) + call clputd ("integral", integ) + } + + call clputl ("ptsused", numused) + + call tbtclo (tp) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tjoin.par b/pkg/utilities/nttools/tjoin.par new file mode 100644 index 00000000..eb078f69 --- /dev/null +++ b/pkg/utilities/nttools/tjoin.par @@ -0,0 +1,9 @@ +intable1,f,a,,,,name of the first table to be joined +intable2,f,a,,,,name of the second table to be joined +outtable,s,a,,,,name of output table +column1,s,a,,,,name of columns to join in first table +column2,s,a,,,,name of columns to join in second table +extrarows,s,h,neither,neither|first|both,,add unmatched rows from which table? +tolerance,s,h,0.0,,,tolerance used in testing for equality +casesens,b,h,yes,,,Case sensitivity flag +mode,s,h,"a",,, diff --git a/pkg/utilities/nttools/tjoin/closeiotab.x b/pkg/utilities/nttools/tjoin/closeiotab.x new file mode 100644 index 00000000..8d9ff7df --- /dev/null +++ b/pkg/utilities/nttools/tjoin/closeiotab.x @@ -0,0 +1,22 @@ +include "tjoin.h" + +# B.Simon 16-Apr-99 first code + +# CLOSE_IOTAB -- Close table and release data structure describing it + +procedure close_iotab (tj) + +pointer tj # i: Data structure describing table +#-- + +begin + call tbtclo (TJ_TAB(tj)) + + if (TJ_JPTR(tj) != NULL) + call mfree (TJ_JPTR(tj), TY_INT) + + if (TJ_DPTR(tj) != NULL) + call mfree (TJ_DPTR(tj), TY_INT) + + call mfree (tj, TY_INT) +end diff --git a/pkg/utilities/nttools/tjoin/dojoin.x b/pkg/utilities/nttools/tjoin/dojoin.x new file mode 100644 index 00000000..133a2721 --- /dev/null +++ b/pkg/utilities/nttools/tjoin/dojoin.x @@ -0,0 +1,97 @@ +include +include "tjoin.h" + +# DOJOIN -- Compute the relational join of two tables +# +# B.Simon 03-Nov-87 First Code +# B.Simon 16-Dec-87 Changed to handle table subsets +# B.Simon 06-Feb-90 Changed to use tbtsrt +# B.Simon 06-Feb-90 Revised to do outer joins + +procedure dojoin (tj1, tj2, tjo, tol, extra, casesens) + +pointer tj1 # i: Table info descriptor for first input table +pointer tj2 # i: Table info descriptor for second input table +pointer tjo # i: Table info descriptor for output table +pointer tol # i: Descriptor of vector of tolerance values +int extra # i: Include non-joined columns in output +bool casesens # i: Join is case sensitive +#-- +int nrow1, nrow2, irow, jrow, krow +pointer match1, match2 + +bool is_same() +int tbpsta() + +begin + # Allocate arrays to hold unmatched rows + # in case extrarows is set + + nrow1 = tbpsta (TJ_TAB(tj1), TBL_NROWS) + nrow2 = tbpsta (TJ_TAB(tj2), TBL_NROWS) + + if (extra > 0) { + call calloc (match1, nrow1, TY_INT) + call calloc (match2, nrow2, TY_INT) + } + + # Naive approach to join compares every row in first table + # to second. This is slower than sorting first (N^2 vs. N log N) + # but the code is much simpler, especially with the extra + # problem of joining on row number and supporting inner and + # outer joins. + + krow = 1 + do irow = 1, nrow1 { + do jrow = 1, nrow2 { + # Equality test includes case insensitive string matches + # and fuzzy matching for numbers + + if (is_same (tj1, tj2, irow, jrow, tol, casesens)) { + # If match, write rows to output table + + call tbrcsc (TJ_TAB(tj1), TJ_TAB(tjo), TJ_DCOL(tj1,1), + TJ_DCOL(tjo,1), irow, krow, TJ_DNUM(tj1)) + call tbrcsc (TJ_TAB(tj2), TJ_TAB(tjo), TJ_DCOL(tj2,1), + TJ_DCOL(tjo,TJ_DNUM(tj1)+1), jrow, krow, + TJ_DNUM(tj2)) + + if (extra > 0) { + Memi[match1+irow-1] = jrow + Memi[match2+jrow-1] = irow + } + + krow = krow + 1 + } + } + } + + # Write the extra rows to the output table + + if (extra >= 1) { + do irow = 1, nrow1 { + if (Memi[match1+irow-1] == 0) { + call tbrcsc (TJ_TAB(tj1), TJ_TAB(tjo), TJ_DCOL(tj1,1), + TJ_DCOL(tjo,1), irow, krow, TJ_DNUM(tj1)) + krow = krow + 1 + } + } + } + + if (extra == 2) { + do jrow = 1, nrow2 { + if (Memi[match2+jrow-1] == 0) { + call tbrcsc (TJ_TAB(tj2), TJ_TAB(tjo), TJ_DCOL(tj2,1), + TJ_DCOL(tjo,TJ_DNUM(tj1)+1), jrow, krow, + TJ_DNUM(tj2)) + krow = krow + 1 + } + } + } + + if (extra > 0) { + call mfree (match1, TY_INT) + call mfree (match2, TY_INT) + } + +end diff --git a/pkg/utilities/nttools/tjoin/freetol.x b/pkg/utilities/nttools/tjoin/freetol.x new file mode 100644 index 00000000..45857c73 --- /dev/null +++ b/pkg/utilities/nttools/tjoin/freetol.x @@ -0,0 +1,15 @@ +include "tjoin.h" + +# B.Simon 16-Apr-99 first code + +# FREE_TOL -- Free the structure containing tolerance values + +procedure free_tol (tol) + +pointer tol # i: Vector of tolerance values +#-- + +begin + call mfree (TOL_PTR(tol), TY_DOUBLE) + call mfree (tol, TY_INT) +end diff --git a/pkg/utilities/nttools/tjoin/isnumber.x b/pkg/utilities/nttools/tjoin/isnumber.x new file mode 100644 index 00000000..3efb0dba --- /dev/null +++ b/pkg/utilities/nttools/tjoin/isnumber.x @@ -0,0 +1,35 @@ +include +include + +# B.Simon 16-Apr-99 first code + +# IS_NUMBER -- Test string to see if it represents a number + +bool procedure is_number (str) + +char str[ARB] # i: String to be tested +#-- +int ic, nc, type +int lexnum() + +begin + # Use lexnum to determine string type + + ic = 1 + type = lexnum (str, ic, nc) + + # Any non-white characters after the number + # indicate this is not a number + + ic = ic + nc + while (str[ic] != EOS) { + if (! IS_WHITE(str[ic])) + return (false) + + ic = ic + 1 + } + + # Test for numeric types and return result of test + + return (type == LEX_OCTAL || type == LEX_DECIMAL || type == LEX_REAL) +end diff --git a/pkg/utilities/nttools/tjoin/issame.x b/pkg/utilities/nttools/tjoin/issame.x new file mode 100644 index 00000000..89ea221d --- /dev/null +++ b/pkg/utilities/nttools/tjoin/issame.x @@ -0,0 +1,127 @@ +include "tjoin.h" + +# B.Simon 16-Apr-99 first code + +# IS_SAME -- See if two values in different tables are the same + +bool procedure is_same (tj1, tj2, irow, jrow, tol, casesens) + +pointer tj1 # i: Table info descriptor for first input table +pointer tj2 # i: Table info descriptor for second input table +int irow # i: Row number of element in first table +int jrow # i: Row number of element in second table +pointer tol # i: Descriptor of vecor of tolerance values +bool casesens # i: Join is case sensitive +#-- +bool same +double dval1, dval2 +int icol, dtype1, dtype2, ival1, ival2 +pointer sp, str1, str2 + +string badtol "Tolerance must be zero for joins on non-numeric columns" +string badtype "Type mismatch on join columns" + +bool streq() +int spp_type() + +begin + # Allocate memory for table strings + + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + + same = true + do icol = 1, TJ_JNUM(tj1) { + if (! same) + break + + # Get column data types + + dtype1 = spp_type (TJ_JCOL(tj1,icol)) + dtype2 = spp_type (TJ_JCOL(tj2,icol)) + + # Comparison depends on data type + + if (dtype1 == TY_CHAR && dtype2 == TY_CHAR) { + # Nonzero tolerance illegal on string columns + + if (TOL_VAL(tol,icol) != 0.0) + call error (1, badtol) + + call tbegtt (TJ_TAB(tj1), TJ_JCOL(tj1,icol), irow, + Memc[str1], SZ_LINE) + call tbegtt (TJ_TAB(tj2), TJ_JCOL(tj2,icol), jrow, + Memc[str2], SZ_LINE) + + # Convert to lower case for case insensitive match + + if (! casesens) { + call strlwr (Memc[str1]) + call strlwr (Memc[str2]) + } + + # Test for undefined values first, which never match + + if (Memc[str1] == EOS || Memc[str2] == EOS) { + same = false + } else { + same = streq (Memc[str1], Memc[str2]) + } + + } else if (dtype1 == TY_BOOL && dtype2 == TY_BOOL) { + # Nonzero tolerance illegal on boolean column + + if (TOL_VAL(tol,icol) != 0.0) + call error (1, badtol) + + # Read boolean as integer so we can detect undefined values + + call tbegti (TJ_TAB(tj1), TJ_JCOL(tj1,icol), irow, ival1) + call tbegti (TJ_TAB(tj2), TJ_JCOL(tj2,icol), jrow, ival2) + + # Undefined values never match anything + + if (IS_INDEFI(ival1) || IS_INDEFI(ival2)) { + same = false + } else { + same = ival1 == ival2 + } + + } else if (dtype1 == TY_CHAR || dtype1 == TY_BOOL || + dtype2 == TY_BOOL || dtype2 == TY_BOOL) { + + # Catch comparison of numeric and non-numeric values + + call error (1, badtype) + + } else { + # Null column pointer indicates the join is done on row number + + if (TJ_JCOL(tj1,icol) == NULL) { + dval1 = irow + } else { + call tbegtd (TJ_TAB(tj1), TJ_JCOL(tj1,icol), irow, dval1) + } + + if (TJ_JCOL(tj2,icol) == NULL) { + dval2 = jrow + } else { + call tbegtd (TJ_TAB(tj2), TJ_JCOL(tj2,icol), jrow, dval2) + } + + # Undefined values never match + # Numeric values must be checked to see if the + # difference is smaller than the tolerance + + if (IS_INDEFD(dval1) || IS_INDEFD(dval2)) { + same = false + } else { + same = abs (dval2 - dval1) <= TOL_VAL(tol,icol) + } + } + } + + call sfree (sp) + return (same) +end diff --git a/pkg/utilities/nttools/tjoin/mkjoin.x b/pkg/utilities/nttools/tjoin/mkjoin.x new file mode 100644 index 00000000..46667b3e --- /dev/null +++ b/pkg/utilities/nttools/tjoin/mkjoin.x @@ -0,0 +1,106 @@ +include + +# MKJOIN -- Create a table that will hold the join of two other tables +# +# B.Simon 04-Nov-87 First Code +# B.Simon 31-Mar-92 Set output table type from input tables +# B.Simon 14-Apr-99 Extracted code that creates table + +pointer procedure mkjoin (tol, tp1, cp1, tp2, cp2, outtable, otp, + cpvec1, cpvec2, cpveco, ncol1, ncol2) + +double tol # i: Tolerance used in testing for equality +pointer tp1 # i: Table descriptor of first table +pointer cp1 # i: Descriptor of merged column in first table +pointer tp2 # i: Table descriptor of second table +pointer cp2 # i: Descriptor of merged column in second table +char outtable[ARB] # i: Name of output table +pointer otp # i: Table descriptor of output table +pointer cpvec1[ARB] # i: Vector of columns in first input table +pointer cpvec2[ARB] # i: Vector of columns in second input table +pointer cpveco[ARB] # i: Vector of columns in output table +int ncol1 # i: Number of columns in first input table +int ncol2 # u: Number of columns in second input table +#-- +int icol, jcol, numcol, type1, type2 +int colnum[1], datatype[1], lendata[1], lenfmt[1] +pointer sp, icp, ocp, oldcol, newcol +pointer colname, colunits, colfmt + +int tbpsta(), tbcnum(), tbcigi() +pointer tbtopn() + +begin + # Set up arrays in dynamic memory + + call smark (sp) + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (colunits, SZ_COLUNITS, TY_CHAR) + call salloc (colfmt, SZ_COLFMT, TY_CHAR) + + # Copy column pointers to old column array. If the tolerance is + # zero, the join column in the second table is not copied + + numcol = ncol1 + ncol2 + + do icol = 1, ncol1 + cpvec1[icol] = tbcnum (tp1, icol) + + do icol = 1, ncol2 + cpvec2[icol] = tbcnum (tp2, icol) + + if (tol == 0.0 && cp1 != NULL && cp2 != NULL) { + jcol = tbcigi (cp2, TBL_COL_NUMBER) + ncol2 = ncol2 - 1 + numcol = numcol - 1 + do icol = jcol+1, ncol2 + cpvec2[icol-1] = cpvec2[icol] + } + + # Set type of output table + + otp = tbtopn (outtable, NEW_FILE, NULL) + + type1 = tbpsta (tp1, TBL_WHTYPE) + type2 = tbpsta (tp2, TBL_WHTYPE) + if (type1 == type2) + call tbpset (otp, TBL_WHTYPE, type1) + + # Copy column information from the input tables to the output table + + do icol = 1, ncol1 { + icp = cpvec1[icol] + call tbcinf (icp, colnum, Memc[colname], Memc[colunits], + Memc[colfmt], datatype[1], lendata[1], lenfmt[1]) + + call newcolnam (numcol, Memi[oldcol], icol, + Memc[colname], SZ_COLNAME) + + call tbcdef (otp, ocp, Memc[colname], Memc[colunits], Memc[colfmt], + datatype[1], lendata[1], 1) + cpveco[icol] = ocp + } + + do icol = 1, ncol2 { + icp = cpvec2[icol] + call tbcinf (icp, colnum, Memc[colname], Memc[colunits], + Memc[colfmt], datatype[1], lendata[1], lenfmt[1]) + call newcolnam (numcol, Memi[oldcol], icol, + Memc[colname], SZ_COLNAME) + call tbcdef (otp, ocp, Memc[colname], Memc[colunits], Memc[colfmt], + datatype[1], lendata[1], 1) + cpveco[ncol1+icol] = ocp + } + + # Copy the table columns a row at a time + + call tbtcre (otp) + call tbhcal (tp2, otp) + call tbhcal (tp1, otp) + + call mfree (oldcol, TY_INT) + call mfree (newcol, TY_INT) + call sfree (sp) + + return (otp) +end diff --git a/pkg/utilities/nttools/tjoin/mkpkg b/pkg/utilities/nttools/tjoin/mkpkg new file mode 100644 index 00000000..e421c190 --- /dev/null +++ b/pkg/utilities/nttools/tjoin/mkpkg @@ -0,0 +1,23 @@ +# Update the tjoin application code in the ttools package library +# Author: B.Simon, 25-NOV-1987 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + closeiotab.x "tjoin.h" + dojoin.x "tjoin.h" + freetol.x "tjoin.h" + isnumber.x + issame.x "tjoin.h" + mkjoin.x + openitab.x "tjoin.h" + openotab.x "tjoin.h" + readtol.x "tjoin.h" + removejcol.x "tjoin.h" + renamecol.x "tjoin.h" + spptype.x + tjoin.x "tjoin.h" + ; diff --git a/pkg/utilities/nttools/tjoin/openitab.x b/pkg/utilities/nttools/tjoin/openitab.x new file mode 100644 index 00000000..ebdbcf97 --- /dev/null +++ b/pkg/utilities/nttools/tjoin/openitab.x @@ -0,0 +1,82 @@ +include +include "tjoin.h" + +# B.Simon 16-Apr-99 first code + +# OPEN_ITAB -- Open one of the input tables used in the join + +pointer procedure open_itab (intable, column) + +char intable[ARB] # i: Input table name +char column[ARB] # i: List of join columns +#-- +int ic, icol +pointer tj, sp, cname, errtxt + +string nojoincol "No column supplied as join column" +string badcolnam "Column name not found in table (%s[c:%s])" +string notopen "Could not open table (%s)" + +bool strne() +int tbpsta(), tbcnum(), word_count(), word_fetch() +pointer tbtopn() + +begin + # Allocate memory for temporary strings + + call smark (sp) + call salloc (cname, SZ_COLNAME, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Allocate memory for data structure + + call calloc (tj, LEN_TJSTRUCT, TY_INT) + + # Open table and put descriptor in structure + + iferr { + TJ_TAB(tj) = tbtopn (intable, READ_ONLY, NULL) + } then { + call sprintf (Memc[errtxt], SZ_LINE, notopen) + call pargstr (intable) + call error (1, Memc[errtxt]) + } + + # Create array of data columns + + TJ_DNUM(tj) = tbpsta (TJ_TAB(tj), TBL_NCOLS) + call malloc (TJ_DPTR(tj), TJ_DNUM(tj), TY_INT) + + do icol = 1, TJ_DNUM(tj) + TJ_DCOL(tj,icol) = tbcnum (TJ_TAB(tj), icol) + + # Create array of join columns + + TJ_JNUM(tj) = word_count (column) + if (TJ_JNUM(tj) == 0) + call error (1, nojoincol) + + call malloc (TJ_JPTR(tj), TJ_JNUM(tj), TY_INT) + + ic = 1 + icol = 1 + while (word_fetch (column, ic, Memc[cname], SZ_COLNAME) > 0) { + call tbcfnd (TJ_TAB(tj), Memc[cname], TJ_JCOL(tj,icol), 1) + + if (TJ_JCOL(tj,icol) == NULL) { + if (strne (Memc[cname], ROWNAME)) { + call sprintf (Memc[errtxt], SZ_LINE, badcolnam) + call pargstr (intable) + call pargstr (Memc[cname]) + call error (1, Memc[errtxt]) + } + } + + icol = icol + 1 + } + + # Free temporary memory and return descriptor of new structure + + call sfree (sp) + return (tj) +end diff --git a/pkg/utilities/nttools/tjoin/openotab.x b/pkg/utilities/nttools/tjoin/openotab.x new file mode 100644 index 00000000..bd84ca6a --- /dev/null +++ b/pkg/utilities/nttools/tjoin/openotab.x @@ -0,0 +1,91 @@ +include +include "tjoin.h" + +# B.Simon 16-Apr-99 first code + +# OPEN_OTAB -- Open the output table + +pointer procedure open_otab (outtable, tj1, tj2) + +char outtable[ARB] # i: Output table name +pointer tj1 # i: First input table descriptor +pointer tj2 # i: Second input table descriptor +#-- +int type1, type2, icol, jcol, itab, tji[2] +int colnum, datatype, lendata, lenfmt +pointer tjo, sp, colname, colunits, colfmt, errtxt + +string notopen "Could not open table (%s)" + +int tbpsta() +pointer tbtopn() + +begin + # Allocate memory for temporary strings + + call smark (sp) + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (colunits, SZ_COLUNITS, TY_CHAR) + call salloc (colfmt, SZ_COLFMT, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Allocate memory for data structure + + call malloc (tjo, LEN_TJSTRUCT, TY_INT) + + # Open table and put descriptor in structure + + iferr { + TJ_TAB(tjo) = tbtopn (outtable, NEW_FILE, NULL) + } then { + call sprintf (Memc[errtxt], SZ_LINE, notopen) + call pargstr (outtable) + call error (1, Memc[errtxt]) + } + + # Set table type based on input tables + + type1 = tbpsta (TJ_TAB(tj1), TBL_WHTYPE) + type2 = tbpsta (TJ_TAB(tj2), TBL_WHTYPE) + if (type1 == type2) + call tbpset (TJ_TAB(tjo), TBL_WHTYPE, type1) + + # No join columns are used for output table + + TJ_JNUM(tjo) = 0 + TJ_JPTR(tjo) = NULL + + # Allocate array to hold output table data columns + + TJ_DNUM(tjo) = TJ_DNUM(tj1) + TJ_DNUM(tj2) + call malloc (TJ_DPTR(tjo), TJ_DNUM(tjo), TY_INT) + + # Copy column information from the input tables to the output table + + tji[1] = tj1 + tji[2] = tj2 + + jcol = 1 + do itab = 1, 2 { + do icol = 1, TJ_DNUM(tji[itab]) { + call tbcinf (TJ_DCOL(tji[itab],icol), colnum, Memc[colname], + Memc[colunits], Memc[colfmt], datatype, + lendata, lenfmt) + + call renamecol (tji, itab, icol, Memc[colname], SZ_COLNAME) + + call tbcdef (TJ_TAB(tjo), TJ_DCOL(tjo,jcol), Memc[colname], + Memc[colunits], Memc[colfmt], datatype, + lendata, 1) + + jcol = jcol + 1 + } + } + + call tbtcre (TJ_TAB(tjo)) + call tbhcal (TJ_TAB(tj1), TJ_TAB(tjo)) + call tbhcal (TJ_TAB(tj2), TJ_TAB(tjo)) + + call sfree (sp) + return (tjo) +end diff --git a/pkg/utilities/nttools/tjoin/readtol.x b/pkg/utilities/nttools/tjoin/readtol.x new file mode 100644 index 00000000..4b35f522 --- /dev/null +++ b/pkg/utilities/nttools/tjoin/readtol.x @@ -0,0 +1,55 @@ +include "tjoin.h" +define SZ_VALUE 30 + +# B.Simon 16-Apr-99 first code + +# READ_TOL -- Parse the string containing the vector of tolerance values + +pointer procedure read_tol (tolerance) + +char tolerance[ARB] # i: Comma separated string of tolerance values +#-- +int ic, jc, nc, ival +pointer sp, value, errtxt, tol + +string badvalue "Invalid value in tolerance (%s)" +string negvalue "Negative value in tolerance (%g)" + +bool is_number() +int word_count(), word_fetch(), ctod() + +begin + call smark (sp) + call salloc (value, SZ_VALUE, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + call malloc (tol, LEN_TOLSTRUCT, TY_INT) + + TOL_NUM(tol) = word_count (tolerance) + call malloc (TOL_PTR(tol), TOL_NUM(tol), TY_DOUBLE) + + ic = 1 + ival = 1 + while (word_fetch (tolerance, ic, Memc[value], SZ_VALUE) > 0) { + if (! is_number (Memc[value])) { + call sprintf (Memc[errtxt], SZ_LINE, badvalue) + call pargstr (Memc[value]) + call error (1, Memc[errtxt]) + } + + jc = 1 + nc = ctod (Memc[value], jc, TOL_VAL(tol,ival)) + + if (TOL_VAL(tol,ival) < 0.0) { + call sprintf (Memc[errtxt], SZ_LINE, negvalue) + call pargd (TOL_VAL(tol,ival)) + call error (1, Memc[errtxt]) + } + + ival = ival + 1 + } + + call sfree (sp) + return (tol) +end + diff --git a/pkg/utilities/nttools/tjoin/removejcol.x b/pkg/utilities/nttools/tjoin/removejcol.x new file mode 100644 index 00000000..1578021b --- /dev/null +++ b/pkg/utilities/nttools/tjoin/removejcol.x @@ -0,0 +1,43 @@ +include "tjoin.h" + +# B.Simon 16-Apr-99 first code + +# REMOVE_JCOL -- Remove join columns from list of data columns + +procedure remove_jcol (tj, tol) + +pointer tj # i: Descriptor of table information +pointer tol # i: Vector of tolerances used in equality test +#-- +bool match +int icol, jcol, kcol + +begin + kcol = 0 + do icol = 1, TJ_DNUM(tj) { + # Determine if this column is a join column + # with strict equality testing + + match = false + do jcol = 1, TJ_JNUM(tj) { + if (TJ_DCOL(tj,icol) == TJ_JCOL(tj,jcol) && + TOL_VAL(tol,jcol) == 0.0) { + match = true + break + } + } + + # Don't copy these columns as they duplicate the values + # in the join column in the other table. Also don't copy + # if icol == kcol in order to save time + + if (! match) { + kcol = kcol + 1 + if (kcol < icol) + TJ_DCOL(tj,kcol) = TJ_DCOL(tj,icol) + } + } + + TJ_DNUM(tj) = kcol +end + diff --git a/pkg/utilities/nttools/tjoin/renamecol.x b/pkg/utilities/nttools/tjoin/renamecol.x new file mode 100644 index 00000000..03d87041 --- /dev/null +++ b/pkg/utilities/nttools/tjoin/renamecol.x @@ -0,0 +1,109 @@ +include +include +include "tjoin.h" + +# RENAMECOL -- Rename a column to make its name unique +# +# If the name of the column pointed to by that index is unique, it is output +# as the new name. If it is not unique, a suffix of the form "_i" is appended +# to the name, where i is a digit which (hopefully) makes the name unique. +# +# B.Simon 03-Nov-87 first code +# B.Simon 04-Sep-90 Replaced call to strncmp with streq +# B.Simon 16-Apr-99 Revised version to work with tjoin + +procedure renamecol (tji, jtab, jcol, colname, maxch) + +pointer tji[2] # i: Array of table info descriptors +int jtab # i: Index of table containing column +int jcol # i: Index of column within table +char colname # u: Column name +int maxch # i: Max length of column name +#-- +bool before +int olen, nmatch, nbefore, itab, icol +pointer sp, oldnam, tmpnam, errtxt + +string notuniq "Cannot create a unique column name (%s)" + +bool streq() +int strlen() + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (oldnam, SZ_COLNAME, TY_CHAR) + call salloc (tmpnam, SZ_COLNAME, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Copy name to temporrary variable + + call strcpy (colname, Memc[oldnam], SZ_COLNAME) + call strupr (Memc[oldnam]) + + # See if the name is unique, and if not, how many columns with + # the same name precede this one + + nmatch = 0 + nbefore = 0 + before = true + + do itab = 1, 2 { + do icol = 1, TJ_DNUM(tji[itab]) { + call tbcigt (TJ_DCOL(tji[itab],icol), TBL_COL_NAME, + Memc[tmpnam], SZ_COLNAME) + call strupr (Memc[tmpnam]) + + if (streq (Memc[tmpnam], Memc[oldnam])) { + nmatch = nmatch + 1 + + if (before) + nbefore = nbefore + 1 + } + + if (itab == jtab && icol == jcol) + before = false + } + } + + # If the name is not unique, add a suffix of the form "_i" + + if (nmatch > 1) { + + # Check for ridiculous values of maxch + + olen = min (maxch-2, strlen(Memc[oldnam])) + if (olen < 1) { + call sprintf (Memc[errtxt], SZ_LINE, notuniq) + call pargstr (Memc[oldnam]) + call error (1, Memc[errtxt]) + } + + # Add the suffix + + Memc[oldnam+olen] = '_' + Memc[oldnam+olen+1] = TO_DIGIT (nbefore) + Memc[oldnam+olen+2] = EOS + + # Make sure it is unique + + do itab = 1, 2 { + do icol = 1, TJ_DNUM(tji[itab]) { + call tbcigt (TJ_DCOL(tji[itab],icol), TBL_COL_NAME, + Memc[tmpnam], SZ_COLNAME) + + if (streq (Memc[oldnam], Memc[tmpnam])) { + call sprintf (Memc[errtxt], SZ_LINE, notuniq) + call pargstr (Memc[oldnam]) + call error (1, Memc[errtxt]) + } + } + } + } + + # Copy to the output string + + call strcpy (Memc[oldnam], colname, maxch) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tjoin/spptype.x b/pkg/utilities/nttools/tjoin/spptype.x new file mode 100644 index 00000000..e454c9ba --- /dev/null +++ b/pkg/utilities/nttools/tjoin/spptype.x @@ -0,0 +1,29 @@ +include + +# B.Simon 16-Apr-99 first code + +# SPP_TYPE -- Retrieve the spp type of a table column + +int procedure spp_type (cp) + +pointer cp # i: Column pointer +#-- +int dtype +int tbcigi() + +begin + if (cp == NULL) { + # Null column pointer indicates row number + + dtype = TY_INT + + } else { + # Table data types store strings as negative values + + dtype = tbcigi (cp, TBL_COL_DATATYPE) + if (dtype < 0) + dtype = TY_CHAR + } + + return (dtype) +end diff --git a/pkg/utilities/nttools/tjoin/tjoin.h b/pkg/utilities/nttools/tjoin/tjoin.h new file mode 100644 index 00000000..2e7155b0 --- /dev/null +++ b/pkg/utilities/nttools/tjoin/tjoin.h @@ -0,0 +1,27 @@ +# TJOIN.H -- Constants and data structures used by tjoin + +define ROWNAME "row" # string that indicates row number + # as join column + +# Structure used to hold information about tables + +define LEN_TJSTRUCT 7 + +define TJ_TAB Memi[$1] # Table descriptor +define TJ_JNUM Memi[$1+1] # Number of join columns +define TJ_DNUM Memi[$1+2] # Number of data columns +define TJ_JPTR Memi[$1+3] # Pointer to array of join columns +define TJ_DPTR Memi[$1+4] # Pointer to array of data colomns + +define TJ_JCOL Memi[TJ_JPTR($1)+$2-1] +define TJ_DCOL Memi[TJ_DPTR($1)+$2-1] + +# Structure used to hold tolerance vector + +define LEN_TOLSTRUCT 2 + +define TOL_NUM Memi[$1] # Number of tolerance values +define TOL_PTR Memi[$1+1] # Pointer to array of tolerance values + +define TOL_VAL Memd[TOL_PTR($1)+$2-1] + diff --git a/pkg/utilities/nttools/tjoin/tjoin.x b/pkg/utilities/nttools/tjoin/tjoin.x new file mode 100644 index 00000000..39963721 --- /dev/null +++ b/pkg/utilities/nttools/tjoin/tjoin.x @@ -0,0 +1,124 @@ +include +include "tjoin.h" + +define SYNTAX 1 +define BIG_TABLE 5000 + +# TJOIN -- Join two tables on the basis of equality in a common column +# +# B.Simon 03-Nov-1987 First Code +# Phil Hodge 08-Apr-1999 Call tbfpri. +# B.Simon 16-Apr-1999 Support outer join and multiple join columns +# Phil Hodge 21-Jun-2001 Realloc TOL_PTR before copying tolerance value + +procedure t_tjoin() + +pointer intable1 # Names of the first table to be joined +pointer intable2 # Names of the second table to be joined +pointer outtable # Name of output table +pointer column1 # Name of columns to join in first table +pointer column2 # Name of columns to join in second table +pointer extrarows # Include unmatched rows from which table? +pointer tolerance # Tolerance used in testing for equality +bool casesens # Case sensitivity flag +#-- +int phu_copied # set by tbfpri and ignored +int extra, ival +pointer sp, errtxt, tj1, tj2, tjo, tol + +string extraopt "|neither|first|both|" +string badextra "Illegal value for extrarows" +string badjnum "Number of join columns do not match" +string badtolnum "Number of tolereances and join columns do not match" +string badcolnam "Column name not found in table (%s)" + +bool clgetb() +int strdic() +pointer read_tol(), open_itab(), open_otab() + +begin + # Allocate stack memory for strings + + call smark (sp) + call salloc (intable1, SZ_FNAME, TY_CHAR) + call salloc (column1, SZ_COLNAME, TY_CHAR) + call salloc (intable2, SZ_FNAME, TY_CHAR) + call salloc (column2, SZ_COLNAME, TY_CHAR) + call salloc (outtable, SZ_FNAME, TY_CHAR) + call salloc (extrarows, SZ_FNAME, TY_CHAR) + call salloc (tolerance, SZ_FNAME, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Read the task parameters + + call clgstr ("intable1", Memc[intable1], SZ_FNAME) + call clgstr ("intable2", Memc[intable2], SZ_FNAME) + call clgstr ("outtable", Memc[outtable], SZ_FNAME) + + call clgstr ("column1", Memc[column1], SZ_COLNAME) + call clgstr ("column2", Memc[column2], SZ_COLNAME) + + call clgstr ("extrarows", Memc[extrarows], SZ_FNAME) + call clgstr ("tolerance", Memc[tolerance], SZ_FNAME) + casesens = clgetb ("casesens") + + # Check value of extrarows + + extra = strdic (Memc[extrarows], Memc[extrarows], SZ_FNAME, extraopt) + + if (extra == 0) { + call sprintf (Memc[errtxt], SZ_LINE, badextra) + call pargstr (Memc[extrarows]) + call error (SYNTAX, Memc[errtxt]) + } + + extra = extra - 1 + + # Parse the string of tolerance values + + tol = read_tol (Memc[tolerance]) + + # Open the input tables and get the column pointers + + tj1 = open_itab (Memc[intable1], Memc[column1]) + tj2 = open_itab (Memc[intable2], Memc[column2]) + + # Check the number of join columns and tolerances for agreement + + if (TJ_JNUM(tj1) != TJ_JNUM(tj2)) + call error (1, badjnum) + + if (TJ_JNUM(tj1) != TOL_NUM(tol)) { + if (TOL_NUM(tol) == 1) { + TOL_NUM(tol) = TJ_JNUM(tj1) + call realloc (TOL_PTR(tol), TOL_NUM(tol), TY_DOUBLE) + do ival = 2, TJ_JNUM(tj1) + TOL_VAL(tol,ival) = TOL_VAL(tol,1) + } else { + call error (1, badtolnum) + } + } + + # Remove data columns from second table which are also + # join columns in the first table + + call remove_jcol (tj2, tol) + + # Create the output table + + call tbfpri (Memc[intable1], Memc[outtable], phu_copied) + tjo = open_otab (Memc[outtable], tj1, tj2) + + # Compute the join of the two tables + + call dojoin (tj1, tj2, tjo, tol, extra, casesens) + + # Close the tables and free dynamic memory + + call free_tol (tol) + + call close_iotab (tj1) + call close_iotab (tj2) + call close_iotab (tjo) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tlcol.par b/pkg/utilities/nttools/tlcol.par new file mode 100644 index 00000000..c4ba900a --- /dev/null +++ b/pkg/utilities/nttools/tlcol.par @@ -0,0 +1,4 @@ +# parameter file for the tlcol task +table,s,a,"",,,"name of table" +nlist,i,h,4,1,4,"number of items to list" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/tlinear.par b/pkg/utilities/nttools/tlinear.par new file mode 100644 index 00000000..b05d2843 --- /dev/null +++ b/pkg/utilities/nttools/tlinear.par @@ -0,0 +1,10 @@ +intable,s,a,"",,,"input tables" +outtable,s,a,"STDOUT",,,"output tables or STDOUT" +xcol,s,a,"",,,"x column in input tables" +ycol,s,a,"",,,"y column in input tables" +wcol,s,h,"",,,"weight column in input tables" +scol,s,h,"",,,"standard deviation column in input tables" +rows,s,h,"-",,,"range of rows to use for fit" +outcoly,s,h,"yfit",,,"column name for fitted y values" +outcolr,s,h,"yres",,,"column name for residual values" +mode,s,h,"al" diff --git a/pkg/utilities/nttools/tlinear/mkpkg b/pkg/utilities/nttools/tlinear/mkpkg new file mode 100644 index 00000000..0957be91 --- /dev/null +++ b/pkg/utilities/nttools/tlinear/mkpkg @@ -0,0 +1,11 @@ +# Update tlinear in the ttools package library. +# Author: STOBIE, 15-FEB-1989 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + tlinear.x + ; diff --git a/pkg/utilities/nttools/tlinear/tlinear.x b/pkg/utilities/nttools/tlinear/tlinear.x new file mode 100644 index 00000000..c7af6131 --- /dev/null +++ b/pkg/utilities/nttools/tlinear/tlinear.x @@ -0,0 +1,468 @@ +include # to check whether input or output is redirected +include +define MAX_RANGES (SZ_LINE/2) # max number of ranges of row numbers + +# tlinear -- first order fit to y or x and y columns by linear regression +# +# E.B. Stobie 15-Feb-1989 Task created. +# Phil Hodge 4-Oct-1995 Use table name template routines tbnopen, etc. +# Phil Hodge 24-Sep-1997 Replace IS_INDEF with IS_INDEFD. +# Phil Hodge 8-Apr-1999 Call tbfpri. +# Phil Hodge 8-Jun-1999 Set input/output to STDIN/STDOUT if redirected. +# Phil Hodge 38-Aug-2000 Completely exclude points with weight of zero. + +procedure tlinear() + +pointer inlist, outlist # scr for input & output lists of names +char xcol[SZ_COLNAME] # x column name +char ycol[SZ_COLNAME] # y column name +char wcol[SZ_COLNAME] # weight column name +char scol[SZ_COLNAME] # standard deviations column name +char outcoly[SZ_COLNAME] # column name for fitted y values +char outcolr[SZ_COLNAME] # column name for y residual values +char cyu[SZ_COLUNITS] # column units for y +char cxu[SZ_COLUNITS] # column units for x +char cwu[SZ_COLUNITS] # column units for w +char csu[SZ_COLUNITS] # column units for s +char cyf[SZ_COLFMT] # column format for y +char cxf[SZ_COLFMT] # column format for x +char cwf[SZ_COLFMT] # column format for w +char csf[SZ_COLFMT] # column format for s +#-- +pointer sp +pointer list1, list2 # for lists of input and output tables +pointer itp, otp # ptr to table descriptor +pointer xcptr # ptr to x column descriptor +pointer ycptr # ptr to y column descriptor +pointer wcptr # ptr to weighting column descriptor +pointer scptr # ptr to standard deviations +pointer ocpx, ocpy # ptr to output x and y columns +pointer ocpw, ocps # ptr to output w and s columns +pointer ocpf, ocpr # ptr to col descr for output columns +pointer intab, outtab # scr for names of input & output tables +pointer range_string # string which gives ranges of row numbers +pointer points # ptr to valid points array +pointer as, bs, chi2s # storage for fitted results +pointer siga2s, sigb2s # storage for errors +pointer nptss, nrowss # storage for no pts +pointer srms, rmss # storage for rms and mean of residuals + +double s, sx, sy # intermediate variables for fit +double xval, yval # x and y values to be fitted +double wval, sval # weighting values +double fval, rval # fitted values and residuals +double wgt, xpt, ypt # actual values used in fit +double a, b, siga2, sigb2 # coefficients and their sigmas +double chi2, sigdat # chi squared +double avx, t, st2 # intermediate values used in fit +double sr, sr2, srx # intermediate values for rms +double rms, srm # mean and rms of residuals +double yres # individual fitted y values and residuals + +int junk, i +int nrows, count # number of rows, number of tables +int nvalues, stat +int row, npts +int maxtab # maximum number of tables in input list +int ranges[3,MAX_RANGES] +int cxn, cyn, cwn, csn # column number +int cxl, cyl, cwl, csl # lendata +int cxdt, cydt, cwdt, csdt # datatype +int cxfl, cyfl, cwfl, csfl # length of format +int phu_copied # set by tbfpri and ignored + +bool listout # is the output ASCII rather than a table? +bool done, point +bool xpoint, weight, stdev + +int fstati() +pointer tbtopn(), tbnopen() +int tbnget(), tbnlen() +int decode_ranges(), get_next_number() +int tbpsta() +bool streq() + +begin + # Allocate scratch for lists of names and for table names. + call smark (sp) + call salloc (inlist, SZ_FNAME, TY_CHAR) + call salloc (outlist, SZ_FNAME, TY_CHAR) + call salloc (intab, SZ_FNAME, TY_CHAR) + call salloc (outtab, SZ_FNAME, TY_CHAR) + call salloc (range_string, SZ_FNAME, TY_CHAR) + + # Get task parameters. + + if (fstati (STDIN, F_REDIR) == YES) + call strcpy ("STDIN", Memc[inlist], SZ_FNAME) + else + call clgstr ("intable", Memc[inlist], SZ_FNAME) + + if (fstati (STDOUT, F_REDIR) == YES) + call strcpy ("STDOUT", Memc[outlist], SZ_FNAME) + else + call clgstr ("outtable", Memc[outlist], SZ_FNAME) + + call clgstr ("xcol", xcol, SZ_COLNAME) + call clgstr ("ycol", ycol, SZ_COLNAME) + call clgstr ("wcol", wcol, SZ_COLNAME) + call clgstr ("scol", scol, SZ_COLNAME) + call clgstr ("rows", Memc[range_string], SZ_FNAME) + + listout = streq (Memc[outlist], "STDOUT") # ASCII output? + if ( ! listout ) { + call clgstr ("outcoly", outcoly, SZ_COLNAME) + call clgstr ("outcolr", outcolr, SZ_COLNAME) + } + + # Expand the input table list. + list1 = tbnopen (Memc[inlist]) + + if ( ! listout ) { + # Expand the output table list. + list2 = tbnopen (Memc[outlist]) + if (tbnlen (list1) != tbnlen (list2)) { + call tbnclose (list1) + call tbnclose (list2) + call error (1, + "Number of input and output tables not the same") + } + } + + # allocate arrays for results + count = 0 + maxtab = 200 + call malloc (as, maxtab, TY_DOUBLE) + call malloc (bs, maxtab, TY_DOUBLE) + call malloc (chi2s, maxtab, TY_DOUBLE) + call malloc (siga2s, maxtab, TY_DOUBLE) + call malloc (sigb2s, maxtab, TY_DOUBLE) + call malloc (srms, maxtab, TY_DOUBLE) + call malloc (rmss, maxtab, TY_DOUBLE) + call malloc (nrowss, maxtab, TY_INT) + call malloc (nptss, maxtab, TY_INT) + + # Do for each input table. + while (tbnget (list1, Memc[intab], SZ_FNAME) != EOF) { + + itp = tbtopn (Memc[intab], READ_ONLY, NULL) + call tbcfnd (itp, ycol, ycptr, 1) + if (ycptr == NULL) { + call tbtclo (itp) + call eprintf ("column not found in %s\n") + call pargstr (Memc[intab]) + if ( ! listout ) # skip next output table + junk = tbnget (list2, Memc[outtab], SZ_FNAME) + next + } + + call tbcfnd (itp, xcol, xcptr, 1) + if (xcptr != NULL) xpoint = true + else xpoint = false + + call tbcfnd (itp, wcol, wcptr, 1) + if (wcptr != NULL ) { + weight = true + stdev = false + + } + else { + weight = false + call tbcfnd (itp, scol, scptr, 1) + if (scptr != NULL ) stdev = true + else stdev = false + } + + if (decode_ranges (Memc[range_string], ranges, MAX_RANGES, nvalues) + != OK) + call error (1, "bad range of row numbers") + # Create scratch for fitted values and residuals + nrows = tbpsta (itp, TBL_NROWS) + call malloc (points, nrows, TY_BOOL) + + # xpoint = true use xcolumn, else use row for x + # weight = true use weights + # stdev = true (only if weight = false) use standard deviations + + do i = 1, nrows { + Memb[points+i-1] = false + } + + row = 0 + npts = 0 + s = 0. + sx = 0. + sy = 0. + + stat = get_next_number (ranges, row) + done = (stat == EOF) || (row > nrows) + + while (! done) { + + wgt = 1. + xpt = row + call tbegtd (itp, ycptr, row, yval) + + if (!IS_INDEFD(yval)) { + point = true + ypt = yval + + if (xpoint) { + call tbegtd (itp, xcptr, row, xval) + if (!IS_INDEFD(xval)) xpt = xval + else point = false + } + + if (weight) { + call tbegtd (itp, wcptr, row, wval) + if (!IS_INDEFD(wval)) wgt = wval + else point = false + if (wgt == 0.d0) + point = false + } + + if (stdev) { + call tbegtd (itp, scptr, row, sval) + if (!IS_INDEFD(sval)) wgt = 1./(sval*sval) + else point = false + } + } + else point = false + + if (point) { + + Memb[points+row-1] = true + npts = npts + 1 + s = s + wgt + sx = sx + xpt * wgt + sy = sy + ypt * wgt + } + + stat=get_next_number(ranges,row) + done=(stat == EOF) || (row > nrows) + } + + if (npts > 1) { + + avx = sx/s + t = 0. + st2 = 0. + b = 0. + + do i = 1, nrows { + + if (Memb[points+i-1]) { + row = i + xpt = i + wgt = 1. + + call tbegtd (itp, ycptr, row, ypt) + if (xpoint) { + call tbegtd (itp, xcptr, row, xval) + xpt = xval + } + if (weight) { + call tbegtd (itp, wcptr, row, wval) + wgt = wval + } + if (stdev) { + call tbegtd (itp, scptr, row, sval) + wgt = 1. / (sval*sval) + } + + t = xpt - avx + st2 = st2 + t * t * wgt + b = b + t * ypt * wgt + } + } + + if (st2 > 0.) { + + b = b / st2 + a = (sy - sx * b) / s + siga2 = sqrt ((1. + (sx*sx) / (s * st2)) / s) + sigb2 = sqrt (1. / st2) + chi2 = 0. + sr = 0. + sr2 = 0. + + do i = 1, nrows { + + if (Memb[points+i-1]) { + row = i + xpt = i + wgt = 1. + + call tbegtd (itp, ycptr, row, ypt) + if (xpoint) { + call tbegtd (itp, xcptr, row, xval) + xpt = xval + } + if (weight) { + call tbegtd (itp, wcptr, row, wval) + wgt = wval + } + if (stdev) { + call tbegtd (itp, scptr, row, sval) + wgt = 1. / (sval*sval) + } + yres = ypt - (a + b * xpt) + chi2 = chi2 + yres * yres * wgt + sr = sr + yres + sr2 = sr2 + yres * yres + } + } + + sigdat = 1. + if (!weight && !stdev) sigdat = sqrt (chi2 / (npts - 2)) + siga2 = siga2 * sigdat + sigb2 = sigb2 * sigdat + + srm = sr / npts + srx = sr2 - (sr*sr)/npts + rms = sqrt (srx / (npts - 1)) + + # Save fit values + Memd[as+count] = a + Memd[bs+count] = b + Memd[chi2s+count] = chi2 + Memd[siga2s+count] = siga2 + Memd[sigb2s+count] = sigb2 + Memd[srms+count] = srm + Memd[rmss+count] = rms + Memi[nptss+count] = npts + Memi[nrowss+count] = nrows + count = count + 1 + + if (! listout) { + + # Create output table & define columns. + junk = tbnget (list2, Memc[outtab], SZ_FNAME) + call tbfpri (Memc[intab], Memc[outtab], phu_copied) + otp = tbtopn (Memc[outtab], NEW_FILE, NULL) + if (xpoint) { + call tbcinf (xcptr, cxn, xcol, cxu, cxf, cxdt, cxl, + cxfl) + call tbcdef (otp, ocpx, xcol, cxu, cxf, cxdt, cxl, 1) + } + call tbcinf (ycptr, cyn, ycol, cyu, cyf, cydt, cyl, cyfl) + call tbcdef (otp, ocpy, ycol, cyu, cyf, cydt, cyl, 1) + if (weight) { + call tbcinf (wcptr, cwn, wcol, cwu, cwf, cwdt, cwl, + cwfl) + call tbcdef (otp, ocpw, wcol, cwu, cwf, cwdt, cwl, 1) + } + if (stdev) { + call tbcinf (scptr, csn, scol, csu, csf, csdt, csl, + csfl) + call tbcdef (otp, ocps, scol, csu, csf, csdt, csl, 1) + } + call tbcdef (otp, ocpf, + outcoly, "", "", TY_DOUBLE, 1, 1) + call tbcdef (otp, ocpr, + outcolr, "", "", TY_DOUBLE, 1, 1) + call tbtcre (otp) + + # Put info records in the header. + call tbhadt (otp, "intable", Memc[intab]) + if (xpoint) call tbhadt (otp, "xcol", xcol) + call tbhadt (otp, "ycol", ycol) + if (weight) call tbhadt (otp, "wcol", wcol) + if (stdev) call tbhadt (otp, "scol", scol) + call tbhadi (otp, "nrows", nrows) + + call tbhadd (otp, "a", a) + call tbhadd (otp, "b", b) + call tbhadd (otp, "siga2", siga2) + call tbhadd (otp, "sigb2", sigb2) + call tbhadd (otp, "chi2", chi2) + + # Write the values into the output table, and close it. + do i = 1, nrows { + + point = true + row = i + xpt = i + if (xpoint) { + call tbegtd (itp, xcptr, row, xval) + call tbeptd (otp, ocpx, row, xval) + if (IS_INDEFD (xval)) point = false + else xpt = xval + } + if (point) { + fval = a + b * xpt + call tbeptd (otp, ocpf, row, fval) + call tbegtd (itp, ycptr, row, yval) + call tbeptd (otp, ocpy, row, yval) + if (!IS_INDEFD (yval)) { + rval = yval - fval + call tbeptd (otp, ocpr, row, rval) + } + if (weight) { + call tbegtd (itp, wcptr, row, wval) + call tbeptd (otp, ocpw, row, wval) + } + if (stdev) { + call tbegtd (itp, scptr, row, sval) + call tbeptd (otp, ocps, row, sval) + } + } + + } + call tbtclo (otp) + } + } + else { + call printf("Must have at least 2 unique x values.") + call printf(" Cannot fit!\n") + } + } + call mfree (points, TY_BOOL) + call tbtclo (itp) + } + call tbnclose (list1) + if ( ! listout ) + call tbnclose (list2) + + if (count > 0) { + call printf ("# Fit by linear regression (y = a + bx)\n") + call printf (" \n") + call printf ("# Table pts in row pts in fit a") + call printf (" b\n") + call printf (" \n") + + do i = 1, count { + call printf ("%6d %10d %13d %18.8g %18.8g\n") + call pargi (i) + call pargi (Memi[nrowss+i-1]) + call pargi (Memi[nptss+i-1]) + call pargd (Memd[as+i-1]) + call pargd (Memd[bs+i-1]) + } + call printf (" \n") + call printf (" \n") + + call printf("# Table siga2 sigb2 chi2") + call printf(" residual rms residual mean\n") + call printf (" \n") + do i = 1, count { + call printf (" %d %13.7g %13.7g %13.7g %13.7g %13.7g\n") + call pargi (i) + call pargd (Memd[siga2s+i-1]) + call pargd (Memd[sigb2s+i-1]) + call pargd (Memd[chi2s+i-1]) + call pargd (Memd[rmss+i-1]) + call pargd (Memd[srms+i-1]) + } + } + call mfree (as, TY_DOUBLE) + call mfree (bs, TY_DOUBLE) + call mfree (chi2s, TY_DOUBLE) + call mfree (siga2s, TY_DOUBLE) + call mfree (sigb2s, TY_DOUBLE) + call mfree (srms, TY_DOUBLE) + call mfree (rmss, TY_DOUBLE) + call mfree (nptss, TY_INT) + call mfree (nrowss, TY_INT) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tmatch.par b/pkg/utilities/nttools/tmatch.par new file mode 100644 index 00000000..5cbb516f --- /dev/null +++ b/pkg/utilities/nttools/tmatch.par @@ -0,0 +1,18 @@ +input1,s,a,,,,First input table +input2,s,a,,,,Second input table +output,s,a,,,,Output table +match1,s,a,,,,Columns to match in first table +match2,s,a,,,,Columns to match in second table +maxnorm,r,a,,0.0,,Maximum distance for allowed match +incol1,s,h," ",,,Columns copied to output from first table +incol2,s,h," ",,,Columns copied to output from second table +factor,s,h," ",,,Weighting factors used in computing distance +diagfile,s,h," ",,,Diagnostic output file +nmcol1,s,h," ",,,ID columns in diagnostic output from first table +nmcol2,s,h," ",,,ID columns in diagnostic output from second table +sphere,b,h,no,,,Apply spherical correction? + + + + + diff --git a/pkg/utilities/nttools/tmatch/getmatch.x b/pkg/utilities/nttools/tmatch/getmatch.x new file mode 100644 index 00000000..083d4156 --- /dev/null +++ b/pkg/utilities/nttools/tmatch/getmatch.x @@ -0,0 +1,101 @@ +#* HISTORY * +#* B.Simon 24-Aug-94 Original +#* B.Simon 18-Sep-00 Revised search termination criterion + +# GETMATCH -- Find rows in second table witch match rows in first + +procedure getmatch (in1, in2, ncol, col1, col2, weight, nrow1, index1, + nrow2, index2, maxnorm, sphere, closest, dist) + +pointer in1 # i: first table descriptor +pointer in2 # i: second table descriptor +int ncol # i: number of match columns +pointer col1[ARB] # i: match columns in first table +pointer col2[ARB] # i: match columns in second table +double weight[ARB] # i: weights used in computing norm +int nrow1 # i: number of rows in first table +int index1[ARB] # i: sorted row indices for first table +int nrow2 # i: number of rows in second table +int index2[ARB] # i: sorted row indices for second table +double maxnorm # i: maximum norm used in match +bool sphere # i: apply spherical correction to first column? +int closest[ARB] # o: closest match in second table to first +double dist[ARB] # o: distance between matched rows +#-- +double sqnorm, proj, abnorm, norm, minabnorm, minnorm +int idx, jdx, irow, jrow, krow, jlast + +begin + jlast = 1 + sqnorm = maxnorm * maxnorm + + # Find the row in the second table which minimizes the norm for + # each row of the first table + + + do idx = 1, nrow1 { + irow = index1[idx] + jrow = index2[jlast] + + # The initial guess is the row which matched last time + + call getnorm (in1, in2, ncol, col1, col2, irow, jrow, + weight, sphere, proj, abnorm, norm) + + minabnorm = abnorm + minnorm = norm + krow = jrow + + # Search backwards for a row which minimizes the norm + # Terminate the search when the first dimension of the norm (proj) + # is greater than the minimum norm, as all subsequent rows have + # norms that must be greater than the minimum + + do jdx = jlast-1, 1, -1 { + jrow = index2[jdx] + + call getnorm (in1, in2, ncol, col1, col2, irow, jrow, + weight, sphere, proj, abnorm, norm) + + if (proj > minabnorm) + break + + if (norm < minnorm) { + minabnorm = abnorm + minnorm = norm + krow = jrow + } + } + + # Search forwards for a row that minimizes the norm + # Use the same termination condition as for the forwards search + + do jdx = jlast+1, nrow2 { + jrow = index2[jdx] + + call getnorm (in1, in2, ncol, col1, col2, irow, jrow, + weight, sphere, proj, abnorm, norm) + + if (proj > minabnorm) + break + + if (norm < minnorm) { + minabnorm = abnorm + minnorm = norm + krow = jrow + } + } + + if (minnorm > sqnorm) { + dist[irow] = maxnorm + closest[irow] = 0 + } else { + dist[irow] = sqrt (minnorm) + closest[irow] = krow + } + + jlast = krow + } + +end + diff --git a/pkg/utilities/nttools/tmatch/getnorm.x b/pkg/utilities/nttools/tmatch/getnorm.x new file mode 100644 index 00000000..fed277c6 --- /dev/null +++ b/pkg/utilities/nttools/tmatch/getnorm.x @@ -0,0 +1,67 @@ +include + +#* HISTORY * +#* B.Simon 24-Aug-94 original +#* B.Simon 18-Sep-00 Revised computation of proj and added abnorm + +# GETNORM -- Compute the squared norm between two table rows + +procedure getnorm (in1, in2, ncol, col1, col2, row1, row2, weight, sphere, + proj, abnorm, norm) + +pointer in1 # i: first table descriptor +pointer in2 # i: second table descriptor +int ncol # i: number of match columns +pointer col1[ARB] # i: match columns in first table +pointer col2[ARB] # i: match columns in second table +int row1 # i: row number in first table +int row2 # i: row number in second table +double weight[ARB] # i: weights used in computing norm +bool sphere # i: apply spherical correction to first column? +double proj # o: projection of norm on first axis +double abnorm # o: norm, possibly without spherical correction +double norm # o: norm (distance) between rows in two tables +#-- +int i +double val1, val2, dif + +begin + # Calculate first component of norm + + call tbegtd (in1, col1[1], row1, val1) + call tbegtd (in2, col2[1], row2, val2) + + dif = weight[1] * (val1 - val2) + proj = dif * dif + abnorm = proj + + # Apply correction for spherical coordinates + + if (sphere) { + if (dif > 180) { + dif = dif - 360 + } else if (dif < -180) { + dif = dif + 360 + } + + call tbegtd (in1, col1[2], row1, val1) + call tbegtd (in2, col2[2], row2, val2) + + val1 = 0.5 * weight[2] * (val1 + val2) + dif = dif * cos (DEGTORAD(val1)) + } + + # Compute remaining components + + norm = dif * dif + do i = 2, ncol { + call tbegtd (in1, col1[i], row1, val1) + call tbegtd (in2, col2[i], row2, val2) + + dif = weight[i] * (val1 - val2) + abnorm = abnorm + dif * dif + norm = norm + dif * dif + } + +end + diff --git a/pkg/utilities/nttools/tmatch/getweight.x b/pkg/utilities/nttools/tmatch/getweight.x new file mode 100644 index 00000000..ef8b9204 --- /dev/null +++ b/pkg/utilities/nttools/tmatch/getweight.x @@ -0,0 +1,96 @@ +include +include + +#* HISTORY * +#* B.Simon 24-Aug-94 original + +# GETWEIGHT -- Get array of weights from list of factors or tables + +procedure getweight (ncol, col1, col2, factor, weight) + +int ncol # i: number of match columns +pointer col1[ARB] # i: match columns from first table +pointer col2[ARB] # i: match columns from second table +char factor[ARB] # i: list of factors +double weight[ARB] # o: array of weights +#-- +double unitval[6] +int invert[6] +int ic, jc, nc, icol, jcol, type1, type2, item +pointer sp, value, unit1, unit2, errmsg + + +data unitval / 1.0, 3600.0, 60.0, 1.0, 15.0, RADIAN / +data invert / NO, YES, YES, NO, NO, NO / + +string unitlist "|seconds|minutes|degrees|hours|radians|" +string badvalue "Value in factor string is not a number (%s)" +string badunits "Units mismatch in column %d of tables" + +int ctod(), word_fetch(), strdic() + +begin + # Allocate memory for temporary strings + + call smark (sp) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (unit1, SZ_FNAME, TY_CHAR) + call salloc (unit2, SZ_FNAME, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Get each string from the list and convert to a number + + ic = 1 + icol = 0 + while (word_fetch (factor, ic, Memc[value], SZ_FNAME) > 0) { + icol = icol + 1 + + jc = 1 + nc = ctod (Memc[value], jc, weight[icol]) + if (Memc[value+jc-1] != EOS) { + call sprintf (Memc[errmsg], SZ_LINE, badvalue) + call pargstr (Memc[value]) + + call error (1, Memc[errmsg]) + } + } + + # Set remaining weights according to column units + + do jcol = icol+1, ncol { + # Read units from table + + call tbcigt (col1[jcol], TBL_COL_UNITS, Memc[unit1], SZ_FNAME) + call tbcigt (col2[jcol], TBL_COL_UNITS, Memc[unit2], SZ_FNAME) + + # Search for units in dictionary + + call strlwr (Memc[unit1]) + call strlwr (Memc[unit2]) + + type1 = strdic (Memc[unit1], Memc[unit1], SZ_FNAME, unitlist) + type2 = strdic (Memc[unit2], Memc[unit2], SZ_FNAME, unitlist) + + # Take exit if units do not match + + if (type1 != type2) { + call sprintf (Memc[errmsg], SZ_LINE, badunits) + call pargi (jcol) + + call error (1, Memc[errmsg]) + } + + # Read corresponding weight from unit value array + # The first weight (1.0) is for missing or unknown units + + item = type1 + 1 + + if (invert[item] == NO) { + weight[jcol] = unitval[item] + } else { + weight[jcol] = 1.0 / unitval[item] + } + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tmatch/infomatch.x b/pkg/utilities/nttools/tmatch/infomatch.x new file mode 100644 index 00000000..d90f89a8 --- /dev/null +++ b/pkg/utilities/nttools/tmatch/infomatch.x @@ -0,0 +1,219 @@ +include + +#* HISTORY * +#* B.Simon 25-Aug-94 original + +# INFOMATCH -- Print diagnostic information for tmatch + +procedure infomatch (diagfile, in1, in2, nmcol1, nmcol2, maxnorm, + nclosest, closest, dist) + +char diagfile[ARB] # i: diagnostic output file +pointer in1 # i: first table's descriptor +pointer in2 # i: second table's descriptor +char nmcol1[ARB] # i: name columns in first table +char nmcol2[ARB] # i: name columns in second table +double maxnorm # i: maximum allowed distance between matched rows +int nclosest # i: length of closest array +int closest[ARB] # i: array of closest matches between tables +double dist[ARB] # i: distance between matched rows +#-- +bool first, same +int fd, namelen, mxcol1, mxcol2, ncol1, ncol2, idx, jdx, irow, jrow +pointer sp, index, name, col1, col2 + +string ziptitle "\nThe following objects were not matched:\n" +string duptitle "\nThe following objects matched the same object:\n" +string bigtitle "\nThe following objects have the largest norms:\n" +string normfmt "Norm = %0.7g\n" +string rowformat "%d:%d %s\n" + +bool is_blank() +int open(), envgeti(), tbpsta() + +begin + # Open the diagnostics file + + if (is_blank (diagfile)) + return + + fd = open (diagfile, WRITE_ONLY, TEXT_FILE) + + # Get maximum length of diagnostic string + + iferr { + namelen = envgeti ("ttyncols") - 10 + } then { + namelen = 70 + } + + # Allocate dynamic memory + + call smark (sp) + call salloc (index, nclosest, TY_INT) + call salloc (name, namelen, TY_CHAR) + + # Get column descriptors for name columns + + mxcol1 = tbpsta (in1, TBL_NCOLS) + mxcol2 = tbpsta (in2, TBL_NCOLS) + + call salloc (col1, mxcol1, TY_INT) + call salloc (col2, mxcol2, TY_INT) + + if (is_blank (nmcol1)) { + ncol1 = 0 + } else { + call tctexp (in1, nmcol1, mxcol1, ncol1, Memi[col1]) + } + + if (is_blank (nmcol2)) { + ncol2 = 0 + } else { + call tctexp (in2, nmcol2, mxcol2, ncol2, Memi[col2]) + } + + # Sort the closest array + + call setindex (Memi[index], nclosest) + call sortclose (nclosest, closest, Memi[index]) + + # Print the objects that were not matched + + first = true + do idx = 1, nclosest { + irow = Memi[index+idx-1] + if (closest[irow] != 0) + break + + if (first) { + first = false + call fprintf (fd, ziptitle) + } + + call rowname (in1, irow, ncol1, Memi[col1], Memc[name], namelen) + call fprintf (fd, rowformat) + call pargi (1) + call pargi (irow) + call pargstr (Memc[name]) + } + + # Print the objects which are matched more than once + + same = false + first = true + do idx = 2, nclosest { + irow = Memi[index+idx-1] + jrow = Memi[index+idx-2] + + if (closest[irow] == 0) + next + + if (closest[irow] == closest[jrow]) { + same = true + + if (first) { + first = false + call fprintf (fd, duptitle) + } + + call rowname (in1, jrow, ncol1, Memi[col1], + Memc[name], namelen) + + call fprintf (fd, rowformat) + call pargi (1) + call pargi (jrow) + call pargstr (Memc[name]) + + } else if (same) { + same = false + + call rowname (in1, jrow, ncol1, Memi[col1], + Memc[name], namelen) + + call fprintf (fd, rowformat) + call pargi (1) + call pargi (jrow) + call pargstr (Memc[name]) + + call rowname (in2, closest[jrow], ncol2, Memi[col2], + Memc[name], namelen) + + call fprintf (fd, rowformat) + call pargi (2) + call pargi (closest[jrow]) + call pargstr (Memc[name]) + + call fprintf (fd, "\n") + } + } + + if (same) { + same = false + irow = Memi[index+nclosest-1] + + call rowname (in1, irow, ncol1, Memi[col1], + Memc[name], namelen) + + call fprintf (fd, rowformat) + call pargi (1) + call pargi (irow) + call pargstr (Memc[name]) + + call rowname (in2, closest[irow], ncol2, Memi[col2], + Memc[name], namelen) + + call fprintf (fd, rowformat) + call pargi (2) + call pargi (closest[irow]) + call pargstr (Memc[name]) + + call fprintf (fd, "\n") + } + + # Sort the dist array + + call setindex (Memi[index], nclosest) + call sortdist (nclosest, dist, Memi[index]) + + # Print the ten objects with the largest norms + + jdx = 0 + do idx = nclosest, 1, -1 { + irow = Memi[index+idx-1] + if (dist[irow] == maxnorm) + next + + if (jdx == 0) + call fprintf (fd, bigtitle) + + jdx = jdx + 1 + if (jdx > 10) + break + + call fprintf (fd, normfmt) + call pargd (dist[irow]) + + call rowname (in1, irow, ncol1, Memi[col1], + Memc[name], namelen) + + call fprintf (fd, rowformat) + call pargi (1) + call pargi (irow) + call pargstr (Memc[name]) + + call rowname (in2, closest[irow], ncol2, Memi[col2], + Memc[name], namelen) + + call fprintf (fd, rowformat) + call pargi (2) + call pargi (closest[irow]) + call pargstr (Memc[name]) + + call fprintf (fd, "\n") + + } + + call close (fd) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tmatch/mkpkg b/pkg/utilities/nttools/tmatch/mkpkg new file mode 100644 index 00000000..b6e6be18 --- /dev/null +++ b/pkg/utilities/nttools/tmatch/mkpkg @@ -0,0 +1,20 @@ +# Update the tmatch application code in the ttools package library +# Author: B.Simon, 30-Aug-94 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + getmatch.x + getnorm.x + getweight.x + infomatch.x + putmatch.x + rowname.x + setindex.x + sortclose.x + sortdist.x + tmatch.x + ; diff --git a/pkg/utilities/nttools/tmatch/putmatch.x b/pkg/utilities/nttools/tmatch/putmatch.x new file mode 100644 index 00000000..27407107 --- /dev/null +++ b/pkg/utilities/nttools/tmatch/putmatch.x @@ -0,0 +1,102 @@ +include + +#* HISTORY * +# B.Simon 25-Aug-94 Original + +# PUTMATCH -- Write matched rows in input as a single row in output table + +procedure putmatch (output, incol1, incol2, in1, in2, nclosest, closest) + +char output[ARB] # i: output table name +char incol1[ARB] # i: list of columns to copy from first table +char incol2[ARB] # i: list of columns to copy from second table +pointer in1 # i: first table's descriptor +pointer in2 # i: second table's descriptor +int nclosest # i: length of closest array +int closest[ARB] # i: indices of rows in second table closest to first +#-- +int mxcol1, mxcol2, maxcol, ncol1, ncol2, ncol, type1, type2 +pointer colnum, datatype, lendata, lenfmt, icol, irow, jrow +pointer sp, colname, colunits, colfmt, oldcol, newcol,out + +string nomatch "WARNING: No rows matched between tables, output \ +table is empty\n" + +int tbpsta() +pointer tbtopn() + +begin + # Allocate memory for temporary strings + + call smark (sp) + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (colunits, SZ_COLUNITS, TY_CHAR) + call salloc (colfmt, SZ_COLFMT, TY_CHAR) + + # Get column descriptors from input tables + + mxcol1 = tbpsta (in1, TBL_NCOLS) + mxcol2 = tbpsta (in2, TBL_NCOLS) + maxcol = mxcol1 + mxcol2 + + call salloc (oldcol, maxcol, TY_INT) + call salloc (newcol, maxcol, TY_INT) + + call tctexp (in1, incol1, mxcol1, ncol1, Memi[oldcol]) + call tctexp (in2, incol2, mxcol2, ncol2, Memi[oldcol+ncol1]) + ncol = ncol1 + ncol2 + + # Create output table + + out = tbtopn (output, NEW_FILE, NULL) + + # Set type (text, row ordered, column ordered) + + type1 = tbpsta (in1, TBL_WHTYPE) + type2 = tbpsta (in2, TBL_WHTYPE) + if (type1 == type2) + call tbpset (out, TBL_WHTYPE, type1) + + # Create columns in output table + + do icol = 1, ncol { + call tbcinf (Memi[oldcol+icol-1], colnum, Memc[colname], + Memc[colunits], Memc[colfmt], datatype, + lendata, lenfmt) + + call newcolnam (ncol, Memi[oldcol], icol, + Memc[colname], SZ_COLNAME) + + call tbcdef (out, Memi[newcol+icol-1], Memc[colname], + Memc[colunits], Memc[colfmt], datatype, lendata, 1) + } + + # Copy header keywords from first input table + + call tbtcre (out) + call tbhcal (in1, out) + + # Copy rows from input table to output + + jrow = 0 + do irow = 1, nclosest { + if (closest[irow] == 0) + next + + jrow = jrow + 1 + call tbrcsc (in1, out, Memi[oldcol], Memi[newcol], + irow, jrow, ncol1) + call tbrcsc (in2, out, Memi[oldcol+ncol1], Memi[newcol+ncol1], + closest[irow], jrow, ncol2) + } + + # Write warning message if no rows matched + + if (jrow == 0) + call eprintf (nomatch) + + # Clean up + + call tbtclo (out) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tmatch/rowname.x b/pkg/utilities/nttools/tmatch/rowname.x new file mode 100644 index 00000000..484fcd75 --- /dev/null +++ b/pkg/utilities/nttools/tmatch/rowname.x @@ -0,0 +1,61 @@ +#* HISTORY * +#* B.Simon 26-Aug-94 + +# ROWNAME -- Create name for table row by concatenating column values + +procedure rowname (in, irow, ncol, col, name, namelen) + +pointer in # i: table descriptor +int irow # i: table row number +int ncol # i: number of table columns +pointer col[ARB] # i: table column pointers +char name[ARB] # o: concatenated values of columns +int namelen # i: maximum name length +#-- +int ic, jc, icol +pointer sp, value + +begin + # Allocate memory for column buffer + + call smark (sp) + call salloc (value, SZ_LINE, TY_CHAR) + + # Concatenate column values into name string + + jc = 0 + icol = 0 + for (ic = 1; ic <= namelen; ic = ic + 1) { + + # A value of zero is a flag to read the next coumn + + if (jc == 0) { + icol = icol + 1 + if (icol > ncol) { + if (ic > 1) + ic = ic - 1 # remove trailing blank + + break + } + + call tbegtt (in, col[icol], irow, Memc[value], SZ_LINE) + } + + # Copy a single character from the buffer to the output string + # until the buffer is exhausted. At this point we copy a blank + # as a spacer and set the value of jc as a flag to read the + # next column. + + if (Memc[value+jc] == EOS) { + name[ic] = ' ' + jc = 0 + } else { + name[ic] = Memc[value+jc] + jc = jc + 1 + } + } + + name[ic] = EOS + call sfree (sp) +end + diff --git a/pkg/utilities/nttools/tmatch/setindex.x b/pkg/utilities/nttools/tmatch/setindex.x new file mode 100644 index 00000000..9640f1cd --- /dev/null +++ b/pkg/utilities/nttools/tmatch/setindex.x @@ -0,0 +1,13 @@ +# SETINDEX -- Initialize an index array + +procedure setindex (index, len) + +int index[ARB] # o: index rray +int len # i: array length +#-- +int i + +begin + do i = 1, len + index[i] = i +end diff --git a/pkg/utilities/nttools/tmatch/sortclose.x b/pkg/utilities/nttools/tmatch/sortclose.x new file mode 100644 index 00000000..303ac250 --- /dev/null +++ b/pkg/utilities/nttools/tmatch/sortclose.x @@ -0,0 +1,50 @@ +#* HISTORY * +#* B.Simon 25-Aug-94 original +# Phil Hodge 12-Jul-2005 in sortclose, add 'int cmpclose()' + +# SORTCLOSE -- Sort the closest array + +procedure sortclose (nclosest, closest, index) + +int nclosest # i: length of closest and index arrays +int closest[ARB] # i: indices of second table rows matching first +int index[ARB] # u: indices of first table rows, in sort order on exit +#-- +int cmpclose() +extern cmpclose +pointer sp, close2 + +begin + call smark (sp) + call salloc (close2, nclosest, TY_INT) + + call amovi (closest, Memi[close2], nclosest) + call gqsort (index, nclosest, cmpclose, close2) + + call sfree (sp) +end + +# CMPCLOSE -- Compare two elements in the close array + +int procedure cmpclose (closest, ielem, jelem) + +pointer closest # address of the closest array +int ielem # first element +int jelem # second element +#-- +int order + +begin + if (Memi[closest+ielem-1] < Memi[closest+jelem-1]) { + order = -1 + } else if (Memi[closest+ielem-1] > Memi[closest+jelem-1]) { + order = 1 + } else if (ielem < jelem) { + order = -1 + } else if (ielem < jelem) { + order = 1 + } else { + order = 0 + } + return (order) +end diff --git a/pkg/utilities/nttools/tmatch/sortdist.x b/pkg/utilities/nttools/tmatch/sortdist.x new file mode 100644 index 00000000..b0745676 --- /dev/null +++ b/pkg/utilities/nttools/tmatch/sortdist.x @@ -0,0 +1,50 @@ +#* HISTORY * +#* B.Simon 25-Aug-94 original +# Phil Hodge 28-Sept-2005 in sortdist, add 'int cmpdist()' + +# SORTDIST -- Sort the dist array + +procedure sortdist (ndist, dist, index) + +int ndist # i: length of dist and index arrays +double dist[ARB] # i: indices of second table rows matching first +int index[ARB] # u: indices of first table rows, in sort order on exit +#-- +int cmpdist() +extern cmpdist +pointer sp, dist2 + +begin + call smark (sp) + call salloc (dist2, ndist, TY_DOUBLE) + + call amovd (dist, Memd[dist2], ndist) + call gqsort (index, ndist, cmpdist, dist2) + + call sfree (sp) +end + +# CMPDIST -- Compare two elements in the dist array + +int procedure cmpdist (dist, ielem, jelem) + +pointer dist # address of the dist array +int ielem # first element +int jelem # second element +#-- +int order + +begin + if (Memd[dist+ielem-1] < Memd[dist+jelem-1]) { + order = -1 + } else if (Memd[dist+ielem-1] > Memd[dist+jelem-1]) { + order = 1 + } else if (ielem < jelem) { + order = -1 + } else if (ielem < jelem) { + order = 1 + } else { + order = 0 + } + return (order) +end diff --git a/pkg/utilities/nttools/tmatch/tmatch.x b/pkg/utilities/nttools/tmatch/tmatch.x new file mode 100644 index 00000000..2d3ea22d --- /dev/null +++ b/pkg/utilities/nttools/tmatch/tmatch.x @@ -0,0 +1,138 @@ +include + +#* HISTORY * +#* B.Simon 24-Aug-1994 original +# Phil Hodge 8-Apr-1999 Call tbfpri. + +# TMATCH -- Find closest matching rows between two tables + +procedure tmatch () + +#-- +pointer input1 # First input table +pointer input2 # Second input table +pointer output # Output table +pointer match1 # Columns from first table used to match +pointer match2 # Columns from second table used to match +double maxnorm # Maximum value of norm for allowed match +pointer incol1 # Columns from first table copied to output +pointer incol2 # Columns from second table copied to output +pointer factor # Multiplicative factors used in computing norm +pointer diagfile # Diagnostic output file +pointer nmcol1 # Columns from first table in diagnostic output +pointer nmcol2 # Columns from second table in diagnostic output +bool sphere # Apply spherical correction to first column? + +bool fold +int mxcol1, mxcol2, ncol1, ncol2, nrow1, nrow2 +int phu_copied # set by tbfpri and ignored +pointer sp, in1, in2, col1, col2, index1, index2, weight, dist, closest + +data fold / false / + +string mismatch "Both lists of match columns must have same length" +string nomatch "Match columns not found in table" + +bool clgetb() +double clgetd() +int tbpsta() +pointer tbtopn() + +begin + # Allocate memory for strings + + call smark (sp) + call salloc (input1, SZ_FNAME, TY_CHAR) + call salloc (input2, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (match1, SZ_FNAME, TY_CHAR) + call salloc (match2, SZ_FNAME, TY_CHAR) + call salloc (incol1, SZ_FNAME, TY_CHAR) + call salloc (incol2, SZ_FNAME, TY_CHAR) + call salloc (factor, SZ_FNAME, TY_CHAR) + call salloc (diagfile, SZ_FNAME, TY_CHAR) + call salloc (nmcol1, SZ_FNAME, TY_CHAR) + call salloc (nmcol2, SZ_FNAME, TY_CHAR) + + # Read task parameters + + call clgstr ("input1", Memc[input1], SZ_FNAME) + call clgstr ("input2", Memc[input2], SZ_FNAME) + call clgstr ("output", Memc[output], SZ_FNAME) + call clgstr ("match1", Memc[match1], SZ_FNAME) + call clgstr ("match2", Memc[match2], SZ_FNAME) + maxnorm = clgetd ("maxnorm") + + call clgstr ("incol1", Memc[incol1], SZ_FNAME) + call clgstr ("incol2", Memc[incol2], SZ_FNAME) + call clgstr ("factor", Memc[factor], SZ_FNAME) + call clgstr ("diagfile", Memc[diagfile], SZ_FNAME) + call clgstr ("nmcol1", Memc[nmcol1], SZ_FNAME) + call clgstr ("nmcol2", Memc[nmcol2], SZ_FNAME) + sphere = clgetb ("sphere") + + # Open input tables and get list of match colums + + in1 = tbtopn (Memc[input1], READ_ONLY, NULL) + in2 = tbtopn (Memc[input2], READ_ONLY, NULL) + + mxcol1 = tbpsta (in1, TBL_NCOLS) + mxcol2 = tbpsta (in2, TBL_NCOLS) + + call salloc (col1, mxcol1, TY_INT) + call salloc (col2, mxcol2, TY_INT) + + call tctexp (in1, Memc[match1], mxcol1, ncol1, Memi[col1]) + call tctexp (in2, Memc[match2], mxcol2, ncol2, Memi[col2]) + + if (ncol1 != ncol2) + call error (1, mismatch) + + if (ncol1 == 0) + call error (1, nomatch) + + if (ncol1 < 2) + sphere = false + + # Sort input tables + + call allrows (in1, nrow1, index1) + call allrows (in2, nrow2, index2) + + call tbtsrt (in1, ncol1, Memi[col1], fold, nrow1, Memi[index1]) + call tbtsrt (in2, ncol2, Memi[col2], fold, nrow2, Memi[index2]) + + call salloc (weight, ncol1, TY_DOUBLE) + call salloc (dist, nrow1, TY_DOUBLE) + call salloc (closest, nrow1, TY_INT) + + # Compute weights from list of factors or table column units + + call getweight (ncol1, Memi[col1], Memi[col2], + Memc[factor], Memd[weight]) + + # Compute closest match between the two tables + + call getmatch (in1, in2, ncol1, Memi[col1], Memi[col2], Memd[weight], + nrow1, Memi[index1], nrow2, Memi[index2], maxnorm, + sphere, Memi[closest], Memd[dist]) + + # Write output table + + call tbfpri (Memc[input1], Memc[output], phu_copied) + call putmatch (Memc[output], Memc[incol1], Memc[incol2], in1, in2, + nrow1, Memi[closest]) + + # Write diagnostic info + + call infomatch (Memc[diagfile], in1, in2, Memc[nmcol1], Memc[nmcol2], + maxnorm, nrow1, Memi[closest], Memd[dist]) + + # Clean up + + call mfree (index1, TY_INT) + call mfree (index2, TY_INT) + call tbtclo (in1) + call tbtclo (in2) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tmerge.par b/pkg/utilities/nttools/tmerge.par new file mode 100644 index 00000000..826e5e2c --- /dev/null +++ b/pkg/utilities/nttools/tmerge.par @@ -0,0 +1,9 @@ +# par file for the tmerge task +intable,s,a,"",,,"list of tables" +outtable,s,a,"",,,"name of output table" +option,s,a,"merge","merge|append",,"merge or append?" +allcols,b,h,yes,,,"columns from all input tables?" +tbltype,s,h,"default","row|column|text|default",,"type of output table" +allrows,i,h,100,1,,"number of rows to allocate" +extracol,i,h,0,0,,"number of extra columns to allocate" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/tmerge/mkpkg b/pkg/utilities/nttools/tmerge/mkpkg new file mode 100644 index 00000000..e42cba65 --- /dev/null +++ b/pkg/utilities/nttools/tmerge/mkpkg @@ -0,0 +1,20 @@ +# MKPKG file for the tmerge task +# Author: P.E. Hodge, 14-Sep-87 +# +# Special keywords recognized by standard SDAS mkpkg files: +# +# mkpkg debug=yes link ttools executable with the debugger +# mkpkg linkonly skip ttools library update and just link + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +linkonly: + $call linkonly@.. + ; + +libpkg.a: + tmerge.x + ; diff --git a/pkg/utilities/nttools/tmerge/tmerge.x b/pkg/utilities/nttools/tmerge/tmerge.x new file mode 100644 index 00000000..b489abe2 --- /dev/null +++ b/pkg/utilities/nttools/tmerge/tmerge.x @@ -0,0 +1,425 @@ +include + +define TM_MERGE 1 # option = merge +define TM_APPEND 2 # option = append rows + +# tmerge -- Merge or append tables +# +# Two or more input tables are combined into one output table. +# +# If the option is to append then there will be a separate output row for +# each row of each input table. Columns with the same name in different +# input tables will be written into the same output column, but no data +# will be overwritten because they are written into different rows. +# +# If the option is to merge then each input table is written beginning +# with row one of the output table. There will be as many output rows as +# the largest number of rows in the input tables. If there are columns +# with the same name in different input tables then values will be over- +# written as they are put into the output table. The exception to this +# is text tables if the option allcols=yes; in this case the original +# column names "c1", "c2", etc. will be ignored, and new names will be +# created consisting of the column number in the _output_ table. +# +# Phil Hodge, 2-Sep-1987 Task created. +# Phil Hodge, 7-Sep-1988 Change parameter name for input table. +# Phil Hodge, 16-Mar-1992 Include text as a valid table type. +# Phil Hodge, 16-Apr-1992 Only call tbcdef if column does not exist. +# Phil Hodge, 29-Jun-1992 Allow tbltype = default. +# Phil Hodge, 25-Feb-1993 Create new column names for text tables if +# allcols=yes; in tm_cp_col, use tbcigi & tbcigt instead of +# tbcinf, and get data type from output table instead of input. +# Phil Hodge, 2-Apr-1993 In tm_cp_col, include short datatype. +# Phil Hodge, 10-Nov-1993 In tm_mkname, use strcat instead of sprintf. +# Phil Hodge, 29-Aug-1994 Modify to use tbrcsc instead of copying columns. +# Phil Hodge, 3-Oct-1995 Modify for FITS tables. +# Phil Hodge, 28-May-1996 Rewrite tm_mkname to use parts of dir, table name. +# Phil Hodge, 8-Apr-1999 In tm_create, call tbfpri. +# Phil hodge, 16-Apr-1999 In tm_create, use tbttyp instead of tbparse. +# Phil hodge, 18-Jun-1999 Change the way column names are created for +# text tables: use c, N = column number in output table; +# tm_mkname was rewritten; tm_ch_colnames was eliminated. + +procedure tmerge() + +pointer otp # output table descriptor +pointer sp +pointer tablist # scratch for input list of table names +pointer outtbl # scratch for output table name +pointer ttype # scratch for table type ("row" or "column") +pointer s_option # scratch for "append" or "merge" +int option # TM_MERGE or TM_APPEND +pointer list # filename template list +pointer n_outcols # cumulative number of output columns numbers +bool allcols # no ==> take col def only from first input tbl +pointer tbnopen() +int tbnlen() +bool clgetb() + +begin + call smark (sp) + call salloc (tablist, SZ_LINE, TY_CHAR) + call salloc (outtbl, SZ_LINE, TY_CHAR) + call salloc (ttype, SZ_LINE, TY_CHAR) + call salloc (s_option, SZ_LINE, TY_CHAR) + + call clgstr ("intable", Memc[tablist], SZ_LINE) + call clgstr ("outtable", Memc[outtbl], SZ_LINE) + + call clgstr ("option", Memc[s_option], SZ_FNAME) + if (Memc[s_option] == 'm') + option = TM_MERGE + else if (Memc[s_option] == 'a') + option = TM_APPEND + else + call error (1, "unrecognized 'option'") + allcols = clgetb ("allcols") + call clgstr ("tbltype", Memc[ttype], SZ_FNAME) + + list = tbnopen (Memc[tablist]) + + # For input table i, n_outcols[i] will be the number of columns + # defined in the output table prior to processing table i. + call calloc (n_outcols, tbnlen (list), TY_INT) + + # Create output table. + call tm_create (list, Memc[outtbl], option, allcols, Memc[ttype], + otp, Memi[n_outcols]) + + # Copy contents of all input tables to output table. + call tm_copy (list, otp, Memi[n_outcols], option, allcols) + + call tbtclo (otp) + call tbnclose (list) + call sfree (sp) +end + + +# tm_create -- create output table +# This routine opens (and then closes) each input table in order to +# count header parameters and rows, and define columns. The output table +# is initialized, parameters are set, and the table is created. + +procedure tm_create (list, outtbl, option, allcols, ttype, + otp, n_outcols) + +pointer list # i: filename template descriptor +char outtbl[ARB] # i: name of output table +char ttype[ARB] # i: "row" or "column" ordered +int option # i: merge or append +bool allcols # i: use all input columns? +pointer otp # o: output table pointer +int n_outcols[ARB] # o: cumulative count of output column numbers +#-- +pointer itp # input table descriptor +pointer sp +pointer intbl # scratch for name of an input table +pointer scratch +int num_par # number of header parameters +int itab # input table number +int nrows # sum of number of rows in each input table +int ncols # cumulative number of columns in output table +int allrows # number of rows to allocate in output +int extracol # space for extra columns to allocate in output +int exttype # type of output table implied by extension +int exists, tbttyp() # exists is ignored +int phu_copied # set by tbfpri and ignored +pointer tbtopn() +int clgeti(), tbnget(), tbpsta() + +begin + call smark (sp) + call salloc (intbl, SZ_PATHNAME, TY_CHAR) + call salloc (scratch, SZ_PATHNAME, TY_CHAR) + + call tbnrew (list) # rewind list + if (tbnget (list, Memc[intbl], SZ_PATHNAME) == EOF) # first name + call error (1, "no input") + # If the input and output names are the same post an error. + call tm_same_name (Memc[intbl], outtbl) + itp = tbtopn (Memc[intbl], READ_ONLY, 0) # open first input table + call tbfpri (Memc[intbl], outtbl, phu_copied) # copy primary header + otp = tbtopn (outtbl, NEW_COPY, itp) # open output table + + # Count header parameters and rows, then close first input table. + num_par = tbpsta (itp, TBL_NPAR) + nrows = tbpsta (itp, TBL_NROWS) + call tbtclo (itp) + + # Set parameters. + + call tbpset (otp, TBL_MAXPAR, num_par) + + # Check whether the extension of the output file implies a FITS + # file, while tbltype implies another type. + exttype = tbttyp (outtbl, exists) + if (exttype == TBL_TYPE_FITS) { + if (ttype[1] == 'r' || ttype[1] == 'c' || ttype[1] == 't') { + call eprintf ( + "warning: Extension of output name implies a FITS file,\n") + call eprintf ( + "but tbltype specifies `%s'; output will be FITS.\n") + call pargstr (ttype) + } + } + + if (exttype != TBL_TYPE_FITS) { + + if (ttype[1] == 'r') { # row-ordered stsdas format + call tbpset (otp, TBL_WHTYPE, TBL_TYPE_S_ROW) + extracol = clgeti ("extracol") + # Increase allocation of space for columns. + if (extracol > 0) + call tbpset (otp, TBL_INCR_ROWLEN, extracol) + } else if (ttype[1] == 'c') { # column-ordered stsdas format + call tbpset (otp, TBL_WHTYPE, TBL_TYPE_S_COL) + allrows = clgeti ("allrows") + allrows = max (allrows, nrows) # user may want more rows + call tbpset (otp, TBL_ALLROWS, allrows) + } else if (ttype[1] == 't') { # text table + call tbpset (otp, TBL_WHTYPE, TBL_TYPE_TEXT) + } else if (ttype[1] == 'd') { # default -- don't set type + extracol = clgeti ("extracol") + if (extracol > 0) + call tbpset (otp, TBL_INCR_ROWLEN, extracol) + } + } + + # Open each of the other input tables, define columns, count + # header parameters and rows, and close the table. + itab = 1 # we've opened the first input table already + n_outcols[1] = 0 # no output columns prior to first input table + while (tbnget (list, Memc[intbl], SZ_PATHNAME) != EOF) { + + call tm_same_name (Memc[intbl], outtbl) # check names + itp = tbtopn (Memc[intbl], READ_ONLY, 0) + itab = itab + 1 # increment input table counter + ncols = tbpsta (otp, TBL_NCOLS) # ncols in output table, so far + n_outcols[itab] = n_outcols[itab-1] + ncols + if (allcols) + call tm_def_col (itp, otp, n_outcols[itab]) + num_par = num_par + tbpsta (itp, TBL_NPAR) + if (option == TM_MERGE) + nrows = max (nrows, tbpsta (itp, TBL_NROWS)) + else # append + nrows = nrows + tbpsta (itp, TBL_NROWS) + call tbtclo (itp) + } + + # Create the output table. + call tbtcre (otp) + call sfree (sp) +end + + +# tm_copy -- copy contents of tables +# This routine opens each of the input tables one at a time, copies +# the header parameters to the output table, copies the data contents, +# and closes each input table. + +procedure tm_copy (list, otp, n_outcols, option, allcols) + +pointer list # i: filename template descriptor +pointer otp # i: output table descriptor +int n_outcols[ARB] # i: cumulative count of output column numbers +int option # i: merge or append +bool allcols # i: passed to tm_cp_col (for text tables) +#-- +pointer itp # input table descriptor +pointer sp +pointer intbl # scratch for name of an input table +pointer icp # pointer to column descriptor in input table +pointer ocp # pointer to one column descriptor in output +pointer icptr # array of pointers to col descr in input +pointer ocptr # array of pointers to col descr in output +char colname[SZ_COLNAME] # column name +int itab # input table number +int nrows # number of rows in input table +int irow, orow # loop index for row numbers in input, output +int firstrow # first row to write in output table +int ncols # number of columns in input table +int nc # number of columns to copy to output table +int colnum # loop index for column number +bool simple_text_table # input is a simple text table (no col def)? +pointer tbtopn(), tbcnum() +int tbnget(), tbpsta() + +begin + call smark (sp) + call salloc (intbl, SZ_PATHNAME, TY_CHAR) + + firstrow = 1 # initial values + itab = 0 + call tbnrew (list) # rewind list + + while (tbnget (list, Memc[intbl], SZ_PATHNAME) != EOF) { + + itp = tbtopn (Memc[intbl], READ_ONLY, 0) + itab = itab + 1 # increment input table counter + call tbhcal (itp, otp) # copy all header parameters + nrows = tbpsta (itp, TBL_NROWS) + ncols = tbpsta (itp, TBL_NCOLS) + + simple_text_table = false # initial value + if (tbpsta (itp, TBL_WHTYPE) == TBL_TYPE_TEXT) { + if (tbpsta (itp, TBL_SUBTYPE) == TBL_SUBTYPE_SIMPLE) { + simple_text_table = true + } + } + + if (nrows > 0) { + + # Column descriptors for output table. + call malloc (icptr, ncols, TY_POINTER) + call malloc (ocptr, ncols, TY_POINTER) + + # For each column in the input table, use the column number + # to get its name. Using its name, look for it in the + # current output table. If it is there, save its column + # descriptor in the array; otherwise, ignore the column. + nc = 0 # no columns found yet + do colnum = 1, ncols { + + icp = tbcnum (itp, colnum) + call tbcigt (icp, TBL_COL_NAME, colname, SZ_COLNAME) + + # For a text table, if we're taking values from all + # columns, assign a new column name. + if (allcols && simple_text_table) { + call tm_mkname (n_outcols[itab] + colnum, + colname, SZ_COLNAME) + } + call tbcfnd (otp, colname, ocp, 1) + if (ocp != NULL) { + nc = nc + 1 + Memi[icptr+nc-1] = icp # nc, not colnum + Memi[ocptr+nc-1] = ocp + } + } + + # Copy each row. + orow = firstrow # initial value + do irow = 1, nrows { + call tbrcsc (itp, otp, Memi[icptr], Memi[ocptr], + irow, orow, nc) + orow = orow + 1 + } + # Free memory for column descriptors. + call mfree (ocptr, TY_POINTER) + call mfree (icptr, TY_POINTER) + + if (option == TM_APPEND) # else keep firstrow = 1 + firstrow = firstrow + nrows + } + call tbtclo (itp) + } + call sfree (sp) +end + + +# tm_same_name -- call error if same names +# This routine appends the default extension and then compares the +# two names to make sure they are different. An error is posted if +# the names are the same. + +procedure tm_same_name (tbl1, tbl2) + +char tbl1[ARB], tbl2[ARB] # i: the names to be compared +#-- +pointer name1, name2 # scratch for names including extension +pointer sp +bool streq() + +begin + call smark (sp) + call salloc (name1, SZ_PATHNAME, TY_CHAR) + call salloc (name2, SZ_PATHNAME, TY_CHAR) + call tbtext (tbl1, Memc[name1], SZ_PATHNAME) + call tbtext (tbl2, Memc[name2], SZ_PATHNAME) + if (streq (Memc[name1], Memc[name2])) + call error (1, "input and output names must be different") + call sfree (sp) +end + + +# tm_def_col -- define columns +# All columns in the input table are defined in the output table. +# It is not an error for a column to have been previously defined. +# (Note that this routine is only called if allcols is true.) + +procedure tm_def_col (itp, otp, prev_ncols) + +pointer itp, otp # i: descriptors for input and output tables +int prev_ncols # i: previous number of output columns +#-- +pointer colptr, cp # column descriptors for input & output +char colname[SZ_COLNAME] # column name +char colunits[SZ_COLUNITS] # units for column +char colfmt[SZ_COLFMT] # print format for column +int dtype[1] # data type of column +int lendata[1] # number of elements (one) +int lenfmt # length of print format (ignored) +int ncols # number of columns in input table +int colnum, cn # column number; cn is ignored +int duplicate # count of duplicate columns for text input +bool simple_text_table # input is a simple text table (no col def)? +pointer tbcnum() +int tbpsta() + +begin + ncols = tbpsta (itp, TBL_NCOLS) + + simple_text_table = false # initial value + if (tbpsta (itp, TBL_WHTYPE) == TBL_TYPE_TEXT) { + if (tbpsta (itp, TBL_SUBTYPE) == TBL_SUBTYPE_SIMPLE) { + simple_text_table = true + } + } + + duplicate = 0 # initial value + + do colnum = 1, ncols { + colptr = tbcnum (itp, colnum) + call tbcinf (colptr, + cn, colname, colunits, colfmt, + dtype, lendata, lenfmt) + + # For a simple text table, assign a column name based on the + # number of the column we're about to create in the output table. + if (simple_text_table) + call tm_mkname (prev_ncols+colnum, colname, SZ_COLNAME) + + # Check whether the column already exists ... + call tbcfnd (otp, colname, cp, 1) + # ... and if not then create it. + if (cp == NULL) + call tbcdef (otp, cp, colname, colunits, colfmt, + dtype, lendata, 1) + else if (simple_text_table) + duplicate = duplicate + 1 + } + + if (duplicate > 0) { + call eprintf ( + "warning: %d duplicate column names from text table\n") + call pargi (duplicate) + } +end + + +# tm_mkname -- create a column name +# This routine constructs a new name for a column of a text table. +# The name will be "c" followed by the number of the column in the +# output table. + +procedure tm_mkname (outcol, colname, maxch) + +int outcol # i: number of column in output table +char colname[maxch] # o: column name +int maxch # i: size of colname +#-- + +begin + call sprintf (colname, maxch, "c%d") + call pargi (outcol) +end diff --git a/pkg/utilities/nttools/tprint.par b/pkg/utilities/nttools/tprint.par new file mode 100644 index 00000000..48df6a5c --- /dev/null +++ b/pkg/utilities/nttools/tprint.par @@ -0,0 +1,16 @@ +table,s,a,"",,,"list of tables to print" +prparam,b,h,no,,,"print user parameters?" +prdata,b,h,yes,,,"print data?" +pwidth,i,h,80,40,,"page width if output redirected" +plength,i,h,0,0,,"lines of data per page" +showrow,b,h,yes,,,"print row numbers?" +orig_row,b,h,yes,,,"row numbers are those in underlying table?" +showhdr,b,h,yes,,,"print column names, etc?" +showunits,b,h,yes,,,"print column units?" +columns,s,h,"",,,"list of columns to print" +rows,s,h,"-",,,"range of rows to print" +option,s,h,"plain","plain|html|latex|tex",,"output format option" +align,b,h,yes,,,"increase column width to align with header?" +sp_col,s,h,"",,,"print blank line when this column changes" +lgroup,i,h,0,0,,"print blank line after this many lines" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/tprint/mkpkg b/pkg/utilities/nttools/tprint/mkpkg new file mode 100644 index 00000000..8134ff5b --- /dev/null +++ b/pkg/utilities/nttools/tprint/mkpkg @@ -0,0 +1,15 @@ +# Update tprint and tdump in the ttools package library. +# Author: HODGE, 2-FEB-1988 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + tdump.x + tprint.x + tprhtml.x tprint.h + tprplain.x tprint.h + tprlatex.x tprint.h + ; diff --git a/pkg/utilities/nttools/tprint/notes b/pkg/utilities/nttools/tprint/notes new file mode 100644 index 00000000..2e6f9ff0 --- /dev/null +++ b/pkg/utilities/nttools/tprint/notes @@ -0,0 +1,40 @@ + Structure chart for tprint: 1988 Jan 21 + +tprint: + (tbtopn) + tpr_fm_date: + (finfo) + tpr_param_pr: + (tbhgnp) + tpr_data_pr: + (tctexp) + tpr_plain_pr: + (decode_ranges) + get_page: + (tbcigi) + tpr_pfmt: + (tbcigt) + tpr_cnames_pr: + (tbcigt) + (get_next_number) + prt_row + (tbcigi) + (tbegt[]) + tpr_latex_pr: + (decode_ranges) + tpr_pfmt: + (tbcigt) + tpr_beg_doc + tpr_def + tpr_begin_tbl + tpr_cnames_pr_l: + tpr_w_colsep + (tbcigt) + (get_next_number) + tpr_end_tbl + prt_row_l: + tpr_w_colsep + (tbcigi) + (tbegt[]) + tpr_end_doc + (tbtclo) diff --git a/pkg/utilities/nttools/tprint/tdump.x b/pkg/utilities/nttools/tprint/tdump.x new file mode 100644 index 00000000..54658d58 --- /dev/null +++ b/pkg/utilities/nttools/tprint/tdump.x @@ -0,0 +1,486 @@ +include + +# tdump -- Program to dump a table. +# This differs from tprint in several ways: column names and row numbers +# are not printed, and all columns for a given row are printed (possibly on +# several lines) before moving on to the next row. Also, g format is used +# for floating-point numbers (%15.7g for real, %24.16g for double) regardless +# of the format specification for the column. This is to prevent loss of +# precision. +# +# Phil Hodge, 31-Jul-1987 Task created +# Phil Hodge, 11-Aug-1987 Modify d_gt_col_ptr for datatype=-n for char string. +# Phil Hodge, 30-Dec-1987 Use tctexp for column names. +# Phil Hodge, 7-Sep-1988 Change parameter name for table. +# Phil Hodge, 21-Dec-1988 Also print column descrip; use g format for data. +# Phil Hodge, 9-Mar-1989 Change type of dtype in tbhgnp from char to int. +# Phil Hodge, 9-Jul-1991 Rename parameter pagwidth to pwidth. +# Phil Hodge, 2-Apr-1993 Include short datatype in td_col_def. +# Phil Hodge, 2-Jun-1994 In td_col_ptr, include newline in warning message. +# Phil Hodge, 12-Dec-1994 Include array size in column definitions; +# increase SZ_DTYPE from 9 to 29; +# dump all elements if column is an array. +# Phil Hodge, 15-Dec-1994 Increase size of file names from SZ_FNAME to SZ_LINE. +# Phil Hodge, 13-Jan-1995 Change calling sequence of inquotes. +# Phil Hodge, 19-Jul-1995 Add tp to calling sequence of tl_dtype in td_col_def. +# Phil Hodge, 4-Apr-1996 In td_p_data, start each array at beginning of line; +# change formats for real & double to %13.7g, %22.16g. +# Phil Hodge, 5-Jun-1997 If keywords are to be printed, also print comments. +# Phil Hodge, 20-Jul-1998 Print '' instead of blank for null keywords. +# Phil Hodge, 22-Jul-1998 Left justify strings and boolean elements. +# Phil Hodge, 2-Nov-2000 Use pwidth < 1 to disable the test on page width. +# Phil Hodge, 15-May-2002 Use a specific format for int and short columns; +# this was needed because for x or o format the printed +# values could be misleading. + +define SZ_FMT 16 # size of string containing print format +define FMT_REAL "%13.7g" # format for printing a real +define SPACE_REAL 13 # space required for printing a real +define FMT_DBL "%22.16g" # format for printing a double +define SPACE_DBL 22 # space required for printing a double +define FMT_INT "%11d" # format for printing an int +define SPACE_INT 11 # space required for printing an int +define FMT_SHORT "%5d" # format for printing a short +define SPACE_SHORT 5 # space required for printing a short +define MAX_RANGES (SZ_LINE/2) # max number of ranges of row numbers +define SZ_DTYPE 29 # size of string containing column data type +define SZ_LBUF 2 * SZ_LINE + 1 + +procedure tdump() +#-- +pointer tp # pointer to input table descr +pointer cptr # scratch for array of column pointers +pointer tname # scratch for table name +pointer cname, pname, dname # scratch for names of output files +pointer upar # scratch for header keyword value +pointer comment # scratch for header keyword comment +pointer datatype # scr for array of data types of columns +pointer nelem # scr for array of array lengths of columns +pointer len_fmt # scr for array of lengths of print formats +pointer pformat # scratch for array of print formats +pointer columns # list of columns to be dumped +pointer r_str # string which gives ranges of row numbers +char keyword[SZ_KEYWORD] # buffer for user parameter keyword +char char_type # data type as a letter (t, b, i, r, d) +pointer sp # stack pointer +int fd # file descr for output user param, data +int n # loop index for user parameters +int dtype # data type (TY_CHAR, etc) +int npar # number of user parameters +int nrows, ncols # number of rows and columns in table +int nprint # number of columns to print (may be < ncols) +int pagewidth # page width +bool prcoldef # print column definitions? +bool prparam, prdata # print user parameters? data? +pointer tbtopn() +int open(), clgeti(), tbpsta() + +begin + call smark (sp) + call salloc (tname, SZ_LINE, TY_CHAR) + call salloc (cname, SZ_LINE, TY_CHAR) + call salloc (pname, SZ_LINE, TY_CHAR) + call salloc (dname, SZ_LINE, TY_CHAR) + call clgstr ("table", Memc[tname], SZ_LINE) + + # Get the names of the output files. If a name is null, don't + # write the corresponding portion of the table. + call clgstr ("cdfile", Memc[cname], SZ_LINE) + call clgstr ("pfile", Memc[pname], SZ_LINE) + call clgstr ("datafile", Memc[dname], SZ_LINE) + prcoldef = (Memc[cname] != EOS) + prparam = (Memc[pname] != EOS) + prdata = (Memc[dname] != EOS) + if (!prcoldef && !prparam && !prdata) { + call sfree (sp) # nothing to do + return + } + + tp = tbtopn (Memc[tname], READ_ONLY, 0) + + if (prcoldef || prdata) { + + # If we are to print column definitions and/or data, + # allocate memory and get list of columns. + + call salloc (columns, SZ_LINE, TY_CHAR) + call clgstr ("columns", Memc[columns], SZ_LINE) + ncols = tbpsta (tp, TBL_NCOLS) + + # Allocate enough scratch space for printing all columns. + call salloc (cptr, ncols, TY_POINTER) + call salloc (len_fmt, ncols, TY_INT) + call salloc (datatype, ncols, TY_INT) + call salloc (nelem, ncols, TY_INT) + } + + if (prcoldef) { + + # Open the output file for the column definitions. + fd = open (Memc[cname], NEW_FILE, TEXT_FILE) + + # Print column definitions. + call td_col_def (tp, fd, Memc[columns], Memi[cptr]) + + call close (fd) # column definitions have been written + } + + if (prparam) { + + # Print header parameters. + npar = tbpsta (tp, TBL_NPAR) + if (npar > 0) { + fd = open (Memc[pname], NEW_FILE, TEXT_FILE) + call salloc (upar, SZ_PARREC, TY_CHAR) + call salloc (comment, SZ_PARREC, TY_CHAR) + do n = 1, npar { + # Get the Nth user parameter, and print it. + call tbhgnp (tp, n, keyword, dtype, Memc[upar]) + call tbhgcm (tp, keyword, Memc[comment], SZ_PARREC) + switch (dtype) { + case TY_REAL: + char_type = 'r' + case TY_INT: + char_type = 'i' + case TY_DOUBLE: + char_type = 'd' + case TY_BOOL: + char_type = 'b' + default: + char_type = 't' + } + if (keyword[1] == EOS) { + call fprintf (fd, "'' ") + } else { + call fprintf (fd, "%-8s") + call pargstr (keyword) + } + call fprintf (fd, " %c") + call pargc (char_type) + if (Memc[comment] == EOS) { + call fprintf (fd, " %s\n") + call pargstr (Memc[upar]) + } else { # also print comment + if (char_type == 't') { + call fprintf (fd, " '%s'") # enclose text in quotes + call pargstr (Memc[upar]) + } else { + call fprintf (fd, " %s") # no quotes needed + call pargstr (Memc[upar]) + } + call fprintf (fd, " %s\n") + call pargstr (Memc[comment]) + } + } + call close (fd) # header parameters have been written + } + } + + if (prdata) { + + # Print data portion of table. + nrows = tbpsta (tp, TBL_NROWS) + + if ((nrows < 1) || (ncols < 1)) { + call eprintf ("table is empty\n") + call tbtclo (tp) + call sfree (sp) + return # nothing more to do + } + # Open the output file for the table data. + fd = open (Memc[dname], NEW_FILE, TEXT_FILE) + + call salloc (r_str, SZ_LINE, TY_CHAR) + call clgstr ("rows", Memc[r_str], SZ_LINE) + + pagewidth = clgeti ("pwidth") + if (IS_INDEF(pagewidth)) + pagewidth = -1 # no limit on page width + + # Get column pointers, formats, etc for all columns that are + # to be printed. + call td_col_ptr (tp, Memc[columns], pagewidth, Memi[cptr], + Memi[len_fmt], Memi[datatype], Memi[nelem], nprint) + + if (nprint > 0) { + # Allocate scratch space for print format. (one char for EOS) + call salloc (pformat, (SZ_FMT+1)*nprint, TY_CHAR) + # Print the values in the table. + call td_p_data (tp, fd, Memi[cptr], Memc[r_str], + Memi[len_fmt], Memi[datatype], Memi[nelem], + Memc[pformat], pagewidth, nprint) + } + call close (fd) # data values have been printed + } + call tbtclo (tp) + call sfree (sp) +end + + + +# td_col_def -- print column definitions +# This routine prints the column name, data type, print format, and units +# for all columns that were specified by the user. + +procedure td_col_def (tp, fd, columns, cptr) + +pointer tp # i: pointer to table descriptor +int fd # i: fd for output file +char columns[ARB] # i: list of columns to be dumped +pointer cptr[ARB] # o: array of pointers to column descriptors +#-- +pointer sp +pointer cname, cunits, cfmt # pointers to scratch space for column info +char chartyp[SZ_DTYPE] # data type expressed as a string +int ncols # the total number of columns in the table +int nprint # number of columns to print +int dtype # data type of a column +int nelem # array length +int lenformat # (ignored) +int colnum # column number (ignored) +int k # loop index +int tbpsta() + +begin + call smark (sp) + call salloc (cname, SZ_FNAME, TY_CHAR) + call salloc (cunits, SZ_FNAME, TY_CHAR) + call salloc (cfmt, SZ_COLFMT, TY_CHAR) + + ncols = tbpsta (tp, TBL_NCOLS) + + # Get column pointers for all columns that are to be dumped. + call tctexp (tp, columns, ncols, nprint, cptr) + + # Do for each column that is to be printed. + do k = 1, nprint { + call tbcinf (cptr[k], + colnum, Memc[cname], Memc[cunits], Memc[cfmt], + dtype, nelem, lenformat) + + # Enclose column name in quotes if it contains embedded + # or trailing blanks. + call inquotes (Memc[cname], Memc[cname], SZ_FNAME, YES) + call fprintf (fd, "%-16s") # but name can be longer + call pargstr (Memc[cname]) + + # Print data type. First convert integer data type code to a + # character string, and append info about array size if > 1. + call tl_dtype (tp, cptr[k], dtype, nelem, chartyp, SZ_DTYPE) + call fprintf (fd, " %-8s") + call pargstr (chartyp) + + # Print the format for display. + call fprintf (fd, " %8s") + call pargstr (Memc[cfmt]) + + # Print column units. Ignore trailing blanks. + call inquotes (Memc[cunits], Memc[cunits], SZ_FNAME, NO) + call fprintf (fd, " %s") + call pargstr (Memc[cunits]) + call fprintf (fd, "\n") # end of line for each column + } + call sfree (sp) +end + + +# td_col_ptr -- get column pointers +# This routine gets an array of pointers to the descriptors of those +# columns that are to be printed, plus other info. + +procedure td_col_ptr (tp, columns, pagewidth, + cptr, len_fmt, datatype, nelem, nprint) + +pointer tp # i: pointer to table descriptor +char columns[ARB] # i: list of columns to be dumped +int pagewidth # i: page width (to make sure it's wide enough) +pointer cptr[ARB] # o: array of pointers to column descriptors +int len_fmt[ARB] # o: length of print format for each column +int datatype[ARB] # o: data type for each column +int nelem[ARB] # o: array length of each column +int nprint # o: number of columns to print +#-- +char colname[SZ_COLNAME] # column name for possible error message +int ncols # total number of columns in the table +int k # loop index +int tbpsta(), tbcigi() + +begin + ncols = tbpsta (tp, TBL_NCOLS) + + # Get column pointers for all columns that are to be dumped. + call tctexp (tp, columns, ncols, nprint, cptr) + + # For each column that is to be printed, get the length of the print + # format, and if the column type is string then increase the length + # of the print format by two for possible enclosing quotes. + do k = 1, nprint { + + datatype[k] = tbcigi (cptr[k], TBL_COL_DATATYPE) + nelem[k] = tbcigi (cptr[k], TBL_COL_LENDATA) + + if (datatype[k] == TY_REAL) + len_fmt[k] = SPACE_REAL + else if (datatype[k] == TY_DOUBLE) + len_fmt[k] = SPACE_DBL + else if (datatype[k] == TY_INT) + len_fmt[k] = SPACE_INT + else if (datatype[k] == TY_SHORT) + len_fmt[k] = SPACE_SHORT + else + len_fmt[k] = tbcigi (cptr[k], TBL_COL_FMTLEN) + + if (datatype[k] < 0) # char string column + len_fmt[k] = len_fmt[k] + 2 + + if (pagewidth > 0 && len_fmt[k] > pagewidth) { + call tbcigt (cptr[k], TBL_COL_NAME, colname, SZ_COLNAME) + call eprintf ("Page width is too small for column `%s'.\n") + call pargstr (colname) + } + } +end + + +# td_p_data -- print the contents of the table +# The data in the table are printed one row at a time. + +procedure td_p_data (tp, fd, cptr, range_string, + len_fmt, datatype, nelem, + pformat, pagewidth, nprint) + +pointer tp # i: pointer to table descriptor +int fd # i: fd for output file +pointer cptr[nprint] # i: array of pointers to column descriptors +char range_string[ARB] # i: string which gives ranges of row numbers +int datatype[nprint] # i: array of flags: true if column is a string +int nelem[ARB] # i: array length of each column +int len_fmt[nprint] # i: array of lengths of print formats +char pformat[SZ_FMT,nprint] # io: scratch space for print formats +int pagewidth # i: page width +int nprint # i: number of columns to print +#-- +pointer sp +pointer lbuf # scratch space for line buffer +double dbuf # buffer for double-precision value +real rbuf # buffer for single-precision value +int ibuf # buffer for integer value +short sbuf # buffer for short value +int nrows # number of rows in the table +int rownum, k # loop indices for row, column +int j # loop index for array element +int line_len # current line length +int ranges[3,MAX_RANGES] # ranges of row numbers +int nvalues # returned by decode_ranges and ignored +int stat # returned by get_next_number +bool done # flag for terminating loop +int decode_ranges(), get_next_number() +int tbpsta(), tbagtr(), tbagtd(), tbagti(), tbagts(), tbagtt() +string MISSING "error reading data from table" + +begin + nrows = tbpsta (tp, TBL_NROWS) + + if (decode_ranges (range_string, ranges, MAX_RANGES, nvalues) != 0) { + call eprintf ("bad range of row numbers\n") + return + } + + call smark (sp) + call salloc (lbuf, SZ_LBUF, TY_CHAR) + + # This section gets the print format for each column. The + # format is just "%Ns" or "%-Ns". + do k = 1, nprint { + pformat[1,k] = '%' + if (datatype[k] < 0 || datatype[k] == TY_BOOL) { + call sprintf (pformat[2,k], SZ_FMT-1, "-%ds") # left justify + call pargi (len_fmt[k]) + } else { + call sprintf (pformat[2,k], SZ_FMT-1, "%ds") + call pargi (len_fmt[k]) + } + } + + # This section prints the data. + rownum = 0 # initialize get_next_number + line_len = 0 + done = false + while ( !done ) { + + stat = get_next_number (ranges, rownum) + if ((stat == EOF) || (rownum > nrows)) { + done = true + + } else { + + # Print values in current row. The loop on k is for each + # column that is to be printed. + do k = 1, nprint { + + # If the current column contains arrays, print each + # element, and start at the beginning of the line. + if (nelem[k] > 1 && line_len > 0) { + call fprintf (fd, "\n") + line_len = 0 # reset after newline + } + do j = 1, nelem[k] { + + # If we have previously printed something on the + # current line, print either a space or newline, + # depending on how close we are to the end of the line. + if (line_len > 1) { + if (pagewidth > 0 && + line_len + len_fmt[k] >= pagewidth) { + # need to start a new line + call fprintf (fd, "\n") + line_len = 0 + } else { + # continue on current line + call fprintf (fd, " ") + line_len = line_len + 1 + } + } + + if (datatype[k] == TY_REAL) { + if (tbagtr (tp, cptr[k], rownum, rbuf, j, 1) < 1) + call error (1, MISSING) + call sprintf (Memc[lbuf], SZ_LBUF, FMT_REAL) + call pargr (rbuf) + } else if (datatype[k] == TY_DOUBLE) { + if (tbagtd (tp, cptr[k], rownum, dbuf, j, 1) < 1) + call error (1, MISSING) + call sprintf (Memc[lbuf], SZ_LBUF, FMT_DBL) + call pargd (dbuf) + } else if (datatype[k] == TY_INT) { + if (tbagti (tp, cptr[k], rownum, ibuf, j, 1) < 1) + call error (1, MISSING) + call sprintf (Memc[lbuf], SZ_LBUF, FMT_INT) + call pargi (ibuf) + } else if (datatype[k] == TY_SHORT) { + if (tbagts (tp, cptr[k], rownum, sbuf, j, 1) < 1) + call error (1, MISSING) + call sprintf (Memc[lbuf], SZ_LBUF, FMT_SHORT) + call pargs (sbuf) + } else { + if (tbagtt (tp, cptr[k], rownum, + Memc[lbuf], SZ_LBUF, j, 1) < 1) + call error (1, MISSING) + } + # If the value is a string, enclose in quotes if + # there are embedded blanks (ignore trailing blanks). + if (datatype[k] < 0) + call inquotes (Memc[lbuf], Memc[lbuf], SZ_LINE, NO) + call fprintf (fd, pformat[1,k]) + call pargstr (Memc[lbuf]) + + # Add width of current column. + line_len = line_len + len_fmt[k] + } + } + call fprintf (fd, "\n") # end of current row + line_len = 0 + } + } + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tprint/tprhtml.x b/pkg/utilities/nttools/tprint/tprhtml.x new file mode 100644 index 00000000..6aecd26a --- /dev/null +++ b/pkg/utilities/nttools/tprint/tprhtml.x @@ -0,0 +1,592 @@ +include # for IS_WHITE +include +include "tprint.h" + +define ALIGN_LEFT -1 +define ALIGN_CENTER 0 # currently not used +define ALIGN_RIGHT 1 + +# This file contains subroutines for printing header keywords and/or +# table data in html table format. +# The high-level subroutines are: +# +# tpr_html_begin +# tpr_html_end +# tpr_html_param print header keywords +# tpr_html_pr print table data +# +# Phil Hodge, 9-Aug-1999 Subroutine created + +procedure tpr_html_begin() + +begin + call printf ("\n") + call printf ("\n") +end + +procedure tpr_html_end() + +begin + call printf ("\n") +end + +# tpr_html_pr -- print contents of table +# This version prints the table data in html format. + +procedure tpr_html_pr (tp, colptr, ncp, s_cp, lgroup, + range_string, pagelength, + showrow, orig_row, showhdr, showunits) + +pointer tp # i: pointer to table descriptor +pointer colptr[ncp] # i: array of pointers to column descriptors +int ncp # i: number of columns to print +pointer s_cp # i: pointer to column to control spacing +int lgroup # i: print blank line after this many lines +char range_string[ARB] # i: string which gives ranges of row numbers +int pagelength # i: number of data lines before printing header +bool showrow # i: true if row number is to be printed +bool orig_row # i: show row number from underlying table? +bool showhdr # i: print column names, etc? +bool showunits # i: print column units? +#-- +pointer sp +pointer buf # for a table entry; also for table info +pointer nelem # array length for each column +pointer align # array of flags for column alignment +int max_nelem # maximum of array lengths +bool has_arrays # true if any column contains arrays +bool has_scalars # true if not all columns contain arrays +char rowspan[SZ_FNAME] # string possibly containing ROWSPAN=max_nelem +int nspan # alternate ROWSPAN=nspan, if extra spacing +int linenum # number of lines of data printed +int tmp_linenum # temporary value for linenum +int line_on_page # number of data lines printed on current page +int nrows # number of rows in table +int rownum # row number +int row # row number to be printed +int cn # loop index for column number +int element # loop index for element within array +int ranges[3,MAX_RANGES] # ranges of row numbers +int nvalues # returned by decode_ranges and ignored +int stat # returned by get_next_number +int s_flag # YES if we should add a line for spacing +int s_nelem # array size of s_cp column, or one +bool done # flag for terminating while loop on rows +int decode_ranges(), get_next_number() +int tbpsta(), tbcigi(), tbagtt() +errchk tbsirow + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (nelem, ncp, TY_INT) + call salloc (align, ncp, TY_INT) + + # Get info for each column. + max_nelem = 1 # initial values + if (showrow) + has_scalars = true # row number is a scalar + else + has_scalars = false + + if (s_cp == NULL) + s_nelem = 1 + else + s_nelem = tbcigi (s_cp, TBL_COL_LENDATA) + + do cn = 1, ncp { + + # array length + Memi[nelem+cn-1] = tbcigi (colptr[cn], TBL_COL_LENDATA) + if (Memi[nelem+cn-1] > max_nelem) + max_nelem = Memi[nelem+cn-1] + if (Memi[nelem+cn-1] == 1) + has_scalars = true + + # left or right alignment, depending on print format + call tbcigt (colptr[cn], TBL_COL_FMT, Memc[buf], SZ_LINE) + if (Memc[buf+1] == '-') # e.g. %-12s + Memi[align+cn-1] = ALIGN_LEFT + else + Memi[align+cn-1] = ALIGN_RIGHT + } + if (max_nelem > 1) { + has_arrays = true + nspan = max_nelem # initial value + if (lgroup > 1) { + nspan = nspan + max_nelem / (lgroup - 1) + if (max_nelem / (lgroup - 1) * (lgroup - 1) == max_nelem) + nspan = nspan - 1 # one entire line will be blank + } + call sprintf (rowspan, SZ_FNAME, "ROWSPAN=%d") + call pargi (nspan) + } else { + has_arrays = false + rowspan[1] = EOS + } + + call tbtnam (tp, Memc[buf], SZ_LINE) + + call printf ("\n") + call printf ("tprint of %s\n") + call pargstr (Memc[buf]) + call printf ("\n") + call printf ("\n") + + call printf ("\n") + call printf ("\n") + call printf ("\n") + + nrows = tbpsta (tp, TBL_NROWS) + + if (showhdr) { + call tpr_h_header (tp, colptr, ncp, showrow, showunits, + Memc[buf], SZ_LINE) + } + + if (decode_ranges (range_string, ranges, MAX_RANGES, nvalues) != OK) + call error (1, "bad range of row numbers") + + # Print each row that is to be printed. + linenum = 0 # initialize line counters + line_on_page = 0 + rownum = 0 # initialize get_next_number + stat = get_next_number (ranges, rownum) # get first row number + done = (stat == EOF) || (rownum > nrows) + + while ( !done ) { + + # If we need to insert extra lines for spacing within a column + # that contains arrays, find out the total number of lines + # we'll need to print. Then set ROWSPAN to this new value. + if (s_nelem > 1) { + # Count the total number of elements we'll span. + nspan = max_nelem # initial value + tmp_linenum = linenum + do element = 1, max_nelem { + call tpr_h_space (tp, s_cp, s_nelem, lgroup, + rownum, element, max_nelem, tmp_linenum, nspan) + tmp_linenum = tmp_linenum + 1 + } + # Overwrite original value of rowspan string. + call sprintf (rowspan, SZ_FNAME, "ROWSPAN=%d") + call pargi (nspan) + } + + # If all columns contain arrays, print a blank line. + if (!has_scalars && rownum > 1) + call tpr_h_blank_line (ncp, showrow) + + # Loop over the number of elements in the longest array. + do element = 1, max_nelem { + + # Check whether we should print a blank line. + # (Set pagelength to zero for this call; in tpr_space, + # blocking into groups of lines is reset at the top of + # each page, but we don't do that with html output.) + call tpr_space (tp, s_cp, lgroup, + rownum, element, max_nelem, 0, linenum, s_flag) + + if (s_flag == YES) { + # Print a blank line. + if (has_arrays && element > 1) { + # Print a blank field for each array column. + call printf (" \n") + do cn = 1, ncp { + if (Memi[nelem+cn-1] > 1) + call printf (" \n") + } + call printf (" \n") + } else { + call tpr_h_blank_line (ncp, showrow) + } + linenum = linenum + 1 + line_on_page = line_on_page + 1 + } + + # Print column names again, if appropriate. + if (showhdr && element == 1 && pagelength > 0) { + if (line_on_page >= pagelength) { + call tpr_h_header (tp, colptr, ncp, showrow, showunits, + Memc[buf], SZ_LINE) + line_on_page = 0 + } + } + + call printf (" \n") + + if (element == 1 && showrow) { + if (orig_row) + call tbsirow (tp, rownum, row) + else + row = rownum + if (has_arrays) { + call printf (" \n") + call pargstr (rowspan) + call pargi (row) + } else { + call printf (" \n") + call pargi (row) + } + } + + # Print each column. + do cn = 1, ncp { + + # Does the current column contain arrays? + if (Memi[nelem+cn-1] > 1) { + + if (element <= Memi[nelem+cn-1]) { + if (tbagtt (tp, colptr[cn], rownum, + Memc[buf], SZ_LINE, element, 1) < 1) + call error (1, "can't read array element") + call tpr_cell (Memc[buf], Memi[align+cn-1], + false, "") + } else { + call printf (" \n") + } + + } else if (element == 1) { + + call tbegtt (tp, colptr[cn], rownum, + Memc[buf], SZ_LINE) + if (has_arrays) { + call tpr_cell (Memc[buf], Memi[align+cn-1], + true, rowspan) + } else { + call tpr_cell (Memc[buf], Memi[align+cn-1], + false, "") + } + } + } + + call printf (" \n") + linenum = linenum + 1 + line_on_page = line_on_page + 1 + } + + stat = get_next_number (ranges, rownum) + done = (stat == EOF) || (rownum > nrows) + } + + # Print column names at the end of the document, if appropriate. + if (showhdr && pagelength > 0) { + if (line_on_page >= pagelength) { + call tpr_h_header (tp, colptr, ncp, showrow, showunits, + Memc[buf], SZ_LINE) + } + } + + call printf ("
\n") + call printf ("Table data: %s\n") + call pargstr (Memc[buf]) + call printf ("
 
%d%d 
\n") + call printf ("\n") + call flush (STDOUT) + + call sfree (sp) +end + +procedure tpr_h_blank_line (ncp, showrow) + +int ncp # i: number of columns to print +bool showrow # i: true if we also print row numbers +#-- +int nspan # number of columns to span + +begin + if (showrow) + nspan = ncp + 1 + else + nspan = ncp + + call printf (" \n") + call printf ("  \n") + call pargi (nspan) + call printf (" \n") +end + +# This is a simplified version of tpr_space which just increments the count +# of the number of elements to be spanned in a ROWSPAN tag. +# +# We can't just call tpr_space to do this, because each time it examines +# a row, it saves the current value as 'previous'. We need this routine +# in order to have a separate 'previous' variable. +# +# We don't need to increment linenum if nspan is incremented, because we +# only use this routine for spacing in arrays, and it's the element number +# that we care about for that case. + +procedure tpr_h_space (tp, s_cp, s_nelem, lgroup, + rownum, element, max_nelem, linenum, nspan) + +pointer tp # i: pointer to table descriptor +pointer s_cp # i: pointer to column to control spacing +int s_nelem # i: array size of s_cp column +int lgroup # i: print blank after this many lines +int rownum # i: number of current row +int element # i: array element number +int max_nelem # i: max value for element +int linenum # i: number of lines that have been printed +int nspan # io: incremented if we should increment ROWSPAN +#-- +pointer sp +pointer current # scratch for value of column in current row +int lpage # number of line we would print +int s_flag # YES if we would print a line for spacing +char previous[SZ_LINE] # value of column in previous row +bool do_compare # true if we should compare column values +bool strne() +int junk, tbagtt() +errchk tbegtt, tbagtt + +begin + s_flag = NO # may be changed later + + # linenum is the number of lines that have already been printed. + # lpage is the current line number. + lpage = linenum + 1 + + # If this is the first line, get the current value of the column + # and save it as "previous". That's all. + if (lpage == 1) { + junk = tbagtt (tp, s_cp, rownum, previous, SZ_LINE, element, 1) + return + } + + # Have we printed a group of lines? If so, set the flag to indicate + # that we should print a blank line. + if (lgroup > 1) { + if (max_nelem > 1) { + if (lpage > 1) { + if (lgroup == 2) + s_flag = YES + else if (mod (element, lgroup-1) == 1) + s_flag = YES + } + } else if (mod (lpage, lgroup) == 0) { + s_flag = YES + } + } + + # Check the value in the column. + if (element <= s_nelem) { + if (s_flag == YES) { + # Since we already know we need to print a space, we don't + # have to compare current and previous values, but we still + # must save current value as "previous". + junk = tbagtt (tp, s_cp, rownum, previous, SZ_LINE, + element, 1) + } else { + # Get current value, and compare it with previous value. + call smark (sp) + call salloc (current, SZ_LINE, TY_CHAR) + do_compare = true # may be reset + junk = tbagtt (tp, s_cp, rownum, Memc[current], SZ_LINE, + element, 1) + if (do_compare && strne (Memc[current], previous)) { + # Set flag; save current value as previous value. + s_flag = YES + call strcpy (Memc[current], previous, SZ_LINE) + } + call sfree (sp) + } + } + + # If we should print a line before the first element of an array, + # we'll print a full line, rather than adding one to ROWSPAN; this + # is why we include the test on element. + if (s_flag == YES && element > 1) + nspan = nspan + 1 +end + +# This routine trims trailing blanks from the input buffer (in-place), +# and it sets ip to the index of the first non-blank character. If +# the entire field is blank, the string " " is assigned to the +# input buffer. + +procedure tpr_deblank (buf, ip) + +char buf[ARB] # io: input string (trailing blanks will be truncted) +int ip # o: first non-blank character in buf +#-- +int strlen() + +begin + ip = strlen (buf) + while (ip >= 1 && IS_WHITE(buf[ip])) { # trim trailing blanks + buf[ip] = EOS + ip = ip - 1 + } + ip = 1 + while (IS_WHITE(buf[ip])) # trim leading blanks + ip = ip + 1 + if (buf[ip] == EOS) { + call strcpy (" ", buf, SZ_LINE) + ip = 1 + } +end + +# This routine prints one table element. + +procedure tpr_cell (buf, align, print_rowspan, rowspan) + +char buf[ARB] # io: input string (trailing blanks will be truncted) +int align # i: ALIGN_LEFT or ALIGN_RIGHT +bool print_rowspan # i: true --> print rowspan string +char rowspan[ARB] # i: ROWSPAN= +#-- +int ip # first non-blank character in buf + +begin + call tpr_deblank (buf, ip) + + if (print_rowspan) { + + if (align == ALIGN_LEFT) { + call printf (" %s\n") + call pargstr (rowspan) + call pargstr (buf[ip]) + } else { + call printf (" %s\n") + call pargstr (rowspan) + call pargstr (buf[ip]) + } + + } else { + + if (align == ALIGN_LEFT) { + call printf (" %s\n") + call pargstr (buf[ip]) + } else { + call printf (" %s\n") + call pargstr (buf[ip]) + } + } +end + +procedure tpr_h_header (tp, colptr, ncp, showrow, showunits, buf, maxch) + +pointer tp # i: pointer to table descriptor +pointer colptr[ncp] # i: array of pointers to column descriptors +int ncp # i: number of columns to print +bool showrow # i: true if row number is to be printed +bool showunits # i: print column units? +char buf[ARB] # o: scratch space +int maxch # i: size of buf +#-- +int cn # loop index for column number + +begin + call printf (" \n") + + if (showrow) + call printf (" (row)\n") + + do cn = 1, ncp { + call tbcigt (colptr[cn], TBL_COL_NAME, buf, SZ_LINE) + call printf (" %s\n") + call pargstr (buf) + } + call printf (" \n") + + if (showunits) { + call printf (" \n") + if (showrow) + call printf ("  \n") + do cn = 1, ncp { + call tbcigt (colptr[cn], TBL_COL_UNITS, buf, SZ_LINE) + if (buf[1] == EOS) { + call printf ("  \n") + } else { + call printf (" %s\n") + call pargstr (buf) + } + } + call printf (" \n") + } +end + +# This routine prints all the header keywords for a table. + +procedure tpr_html_param (tp) + +pointer tp # i: pointer to table descriptor +#-- +pointer sp +pointer buf # for a keyword value +pointer comment # keyword comment +int npar # number of header parameters +char keyword[SZ_KEYWORD] # keyword name +int n # loop index for keyword number +int dtype # returned by tbhgnp and ignored +int tbpsta() + +begin + npar = tbpsta (tp, TBL_NPAR) + if (npar <= 0) + return + + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + call salloc (comment, SZ_FNAME, TY_CHAR) + + call tbtnam (tp, Memc[buf], SZ_LINE) + + call printf ("\n") + call printf ("tprint of %s\n") + call pargstr (Memc[buf]) + call printf ("\n") + call printf ("\n") + + call printf ("\n") + call printf ("\n") + call printf ("\n") + + call printf (" \n") + call printf (" \n") + call printf (" \n") + call printf (" \n") + call printf (" \n") + + do n = 1, npar { + + call printf (" \n") + + # Get the Nth header parameter and comment. + call tbhgnp (tp, n, keyword, dtype, Memc[buf]) + call tbhgcm (tp, keyword, Memc[comment], SZ_FNAME) + + if (keyword[1] == EOS) { + call printf (" \n") + } else { + call printf (" \n") + call pargstr (keyword) + } + + if (Memc[buf] == EOS) { + call printf (" \n") + } else { + call printf (" \n") + call pargstr (Memc[buf]) + } + + if (Memc[comment] == EOS) { + call printf (" \n") + } else { + call printf (" \n") + call pargstr (Memc[comment]) + } + + call printf (" \n") + } + + call printf ("
\n") + call printf ("Table keywords: %s\n") + call pargstr (Memc[buf]) + call printf ("
keywordvaluecomment
 %s %s %s
\n") + call printf ("\n") + call flush (STDOUT) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tprint/tprint.h b/pkg/utilities/nttools/tprint/tprint.h new file mode 100644 index 00000000..d0781b1c --- /dev/null +++ b/pkg/utilities/nttools/tprint/tprint.h @@ -0,0 +1,5 @@ +define MAXCOLS 52 # maximum number of columns per page +define SZ_FMT 17 # size of string containing print format +define MAX_RANGES (SZ_LINE/2) # max number of ranges of row numbers +define SHORT_STRING 11 # size of short text strings +define SZ_ROW_HDR 5 # size of header for row number: "# row" diff --git a/pkg/utilities/nttools/tprint/tprint.x b/pkg/utilities/nttools/tprint/tprint.x new file mode 100644 index 00000000..65c2d09d --- /dev/null +++ b/pkg/utilities/nttools/tprint/tprint.x @@ -0,0 +1,535 @@ +include # defines SZ_TIME for datestr +include # defines EA_WARN +include # used by tpr_fm_date +include # used to check whether output is redirected +include +include "tprint.h" + +# tprint -- Program to print tables. +# +# Phil Hodge, 31-Jul-1987 Task created +# Phil Hodge, 11-Aug-1987 Delete call to tbtext. +# Phil Hodge, 28-Aug-1987 Write date that table was last modified. +# Phil Hodge, 12-Oct-1987 Include LaTeX/TeX option. +# Phil Hodge, 30-Dec-1987 Filename template; tctexp for column names. +# Phil Hodge, 12-Feb-1988 Include option to align columns if format is small. +# Phil Hodge, 30-Mar-1988 Page width = ttyncols; get sp_col & lgroup. +# Phil Hodge, 7-Sep-1988 Change parameter name for table. +# Phil Hodge, 10-May-1991 Use clpopns instead of clpopnu. +# Phil Hodge, 26-Mar-1992 Remove call to tbtext; use tbtnam instead. +# Phil Hodge, 28-Oct-1992 Set align=false if showhdr=false. +# Phil Hodge, 5-Jul-1993 Include option to print column units. +# Phil Hodge, 3-Feb-1994 Set showunits to false for a text table. +# Phil Hodge, 15-Dec-1994 Increase size of table name from SZ_FNAME to SZ_LINE. +# Phil Hodge, 16-Feb-1995 In tpr_param_pr, print "#" before header lines. +# Phil Hodge, 6-Mar-1995 In tpr_param_pr, print comment for header parameter. +# Phil Hodge, 23-Jun-1995 In tpr_fm_date, get file name using tbparse. +# Phil Hodge, 3-Oct-1995 Replace clgfil calls with tbn... . +# Phil Hodge, 9-Apr-1996 Error check tbtopn and tpr_data_pr; +# call error if number of columns to print is zero (i.e. if no +# column was found); flush STDOUT. +# Phil Hodge, 5-Jun-1997 Use single instead of double quotes for keyword +# text value, if there's an associated comment. +# Phil Hodge, 26-Mar-1998 Add orig_row to par file, to show row number in +# underlying table in case a row selector was used. +# Phil Hodge, 7-Jun-1999 Allow showunits to be true for a text table; +# this overrides the change made on 3-Feb-1994; +# if input is redirected, set input to STDIN without getting cl param. +# Phil Hodge, 9-Aug-1999 Add option = html; modify tpr_space to handle +# arrays and to just set a flag, rather than actually printing the space. +# Phil Hodge, 3-Jul-2000 In tpr_param_pr, delete leading blanks from the +# value and comment. +# Phil Hodge, 15-Jul-2009 In tpr_fm_date, remove ttype from the call to +# tbparse. + +procedure tprint() + +pointer tp # pointer to input table descr +pointer sp # stack pointer +pointer tname # scratch for table name +pointer columns # scratch for list of column names +pointer range_string # string which gives ranges of row numbers +pointer tlist # for list of input table names +int pagewidth # max number of char in line length +int pagelength # number of data lines (excl header) per page +int lgroup # number of lines to group together on output +bool prparam, prdata # print header parameters? data? +bool showrow # show row number on output? +bool orig_row # show row number from underlying table? +bool showhdr # show table name, column names, etc on output? +bool showunits # show column units on output? +bool align # override print fmt to align col & name? +char prt_option[SHORT_STRING] # "plain", "latex", "tex" +char sp_cname[SZ_COLNAME] # name of column to control spacing +bool first_table # false ==> print line to separate tables +int clgeti(), fstati(), envgeti() +bool clgetb() +pointer tbnopenp(), tbnopen() +int tbnget() +pointer tbtopn() + +begin + call smark (sp) + call salloc (tname, SZ_LINE, TY_CHAR) + call salloc (columns, SZ_LINE, TY_CHAR) + + if (fstati (STDIN, F_REDIR) == YES) + tlist = tbnopen ("STDIN") + else + tlist = tbnopenp ("table") + + # Find out which portions of the table the user wants to print. + prparam = clgetb ("prparam") + prdata = clgetb ("prdata") + if (!prparam && !prdata) { + call sfree (sp) + return + } + + if (prdata) { + # Get parameters relevant to printing data portion of table. + + call salloc (range_string, SZ_LINE, TY_CHAR) + + # Get page width from ttyncols unless output is redirected. + if (fstati (STDOUT, F_REDIR) == YES) + pagewidth = clgeti ("pwidth") + else + pagewidth = envgeti ("ttyncols") + pagelength = clgeti ("plength") + showrow = clgetb ("showrow") + orig_row = clgetb ("orig_row") + call clgstr ("columns", Memc[columns], SZ_LINE) + call clgstr ("rows", Memc[range_string], SZ_LINE) + align = clgetb ("align") + + call clgstr ("sp_col", sp_cname, SZ_COLNAME) + lgroup = clgeti ("lgroup") + 1 # add one for the space + } + + call clgstr ("option", prt_option, SHORT_STRING) + showhdr = clgetb ("showhdr") + if (showhdr) { + showunits = clgetb ("showunits") + } else { + # There's no need to align columns with their names if the names + # are not printed. + align = false + showunits = false + } + + if (prt_option[1] == 'h') # HTML + call tpr_html_begin() + + # Loop over all table names in the file name template. + first_table = true + while (tbnget (tlist, Memc[tname], SZ_LINE) != EOF) { + + if ( ! first_table ) { + call printf ("\n") # blank line between tables + call flush (STDOUT) + } + first_table = false + + # Open the table. + iferr { + tp = tbtopn (Memc[tname], READ_ONLY, 0) + } then { + call erract (EA_WARN) + next + } + + # Get the full table name (for use by tpr_fm_date), + call tbtnam (tp, Memc[tname], SZ_LINE) + + # Print the name of the table and the date that the table was + # last modified. + if (showhdr) + call tpr_fm_date (Memc[tname], prt_option) + + if (prparam) # print header parameters + call tpr_param_pr (tp, prt_option, prdata) + + if (prdata) { # print data portion of table + iferr { + call tpr_data_pr (tp, pagewidth, pagelength, + showrow, orig_row, showhdr, showunits, + align, sp_cname, lgroup, + Memc[columns], Memc[range_string], prt_option) + } then { + call tbtclo (tp) + call erract (EA_WARN) + next + } + } + + call tbtclo (tp) + } + if (prt_option[1] == 'h') # HTML + call tpr_html_end() + + call tbnclose (tlist) + call sfree (sp) +end + + + +# tpr_fm_date -- Get date of file +# This procedure gets the date that a table was last modified and writes +# the table name and date to STDOUT. + +procedure tpr_fm_date (tablename, prt_option) + +char tablename[ARB] # i: name of table +char prt_option[ARB] # i: "plain", "latex", or "tex" +#-- +pointer sp +pointer filename # name of table without brackets +pointer cdfname # returned by tbparse and ignored +int hdu # ignored +long ostruct[LEN_FINFO] # contains info about file +long mtime +char datestr[SZ_TIME] # date that table was last modified +char percent # the % character +int junk, tbparse() +int finfo() + +begin + if (prt_option[1] == 'h') # HTML + return + + call smark (sp) + call salloc (filename, SZ_FNAME, TY_CHAR) + call salloc (cdfname, SZ_FNAME, TY_CHAR) + + # Get file name from table name. + junk = tbparse (tablename, Memc[filename], + Memc[cdfname], SZ_FNAME, hdu) + + percent = '%' + + if (finfo (Memc[filename], ostruct) != ERR) { + mtime = FI_MTIME(ostruct) + call cnvtime (mtime, datestr, SZ_TIME) + + if (prt_option[1] == 'p') { # plain print + call printf ("# Table %s %s\n") + call pargstr (tablename) + call pargstr (datestr) + } else { # LaTeX or TeX + call printf ("%c") + call pargc (percent) # comment + call printf (" Table %s %s\n") + call pargstr (tablename) + call pargstr (datestr) + } + call printf ("\n") + } + call flush (STDOUT) + + call sfree (sp) +end + + + +# tpr_param_pr -- Print header parameters +# This procedure prints the header parameters on STDOUT. +# +# Phil Hodge, 5-Oct-1987 Subroutine created +# Phil Hodge, 30-Dec-1987 If latex or tex, print % prefix. +# Phil hodge, 9-Mar-1989 Change type of dtype in tbhgnp from char to int. + +procedure tpr_param_pr (tp, prt_option, prdata) + +pointer tp # i: pointer to table descriptor +char prt_option[ARB] # i: "plain", "latex", or "tex" +bool prdata # i: print data? (not here, though) +#-- +pointer sp +pointer value # scratch for value of parameter (string) +pointer comment # scratch for comment for parameter +int dtype # data type (TY_CHAR, etc) +int npar # number of header parameters +int n # loop index for parameter number +int ipp, ipc # offsets for skipping leading blanks +char keyword[SZ_KEYWORD] # buffer for header parameter keyword +char percent # the % character +int tbpsta() + +begin + if (prt_option[1] == 'h') { # HTML + call tpr_html_param (tp) + return + } + + percent = '%' + npar = tbpsta (tp, TBL_NPAR) + if (npar > 0) { + call smark (sp) + call salloc (value, SZ_PARREC, TY_CHAR) + call salloc (comment, SZ_PARREC, TY_CHAR) + do n = 1, npar { + + # Get the Nth header parameter and comment. + call tbhgnp (tp, n, keyword, dtype, Memc[value]) + call tbhgcm (tp, keyword, Memc[comment], SZ_PARREC) + ipp = 0 + while (Memc[value+ipp] == ' ') + ipp = ipp + 1 + ipc = 0 + while (Memc[comment+ipc] == ' ') + ipc = ipc + 1 + + if (prt_option[1] != 'p') { # LaTeX or TeX, not plain + call printf ("%c") + call pargc (percent) # comment + } else if (prdata) { # plain output, with data + call printf ("#K ") # comment + } + + # Print the keyword and value, and possibly a comment. + if (Memc[comment+ipc] == EOS) { # no comment to print + + call printf ("%-8s %s\n") + call pargstr (keyword) + call pargstr (Memc[value+ipp]) + + } else if (dtype == TY_CHAR) { + + # Enclose value in quotes to distinguish from comment. + call printf ("%-8s '%s' %s\n") + call pargstr (keyword) + call pargstr (Memc[value+ipp]) + call pargstr (Memc[comment+ipc]) + + } else { + + # Numeric; no quotes needed. + call printf ("%-8s %s %s\n") + call pargstr (keyword) + call pargstr (Memc[value+ipp]) + call pargstr (Memc[comment+ipc]) + } + } + call sfree (sp) + call printf ("\n") + } + call flush (STDOUT) +end + + + +# tpr_data_pr -- Print table data +# This procedure prints the data portion of a table on STDOUT. +# +# Phil Hodge, 5-Oct-1987 Subroutine created +# Phil Hodge, 12-Feb-1988 Include option to align columns if format is small. +# Phil Hodge, 30-Mar-1988 Get column to control spacing of printout. + +procedure tpr_data_pr (tp, pagewidth, pagelength, + showrow, orig_row, showhdr, showunits, + align, sp_cname, lgroup, + columns, range_string, prt_option) + +pointer tp # i: pointer to table descriptor +int pagewidth # i: page width +int pagelength # i: number of lines of table per page +bool showrow # i: print row number? +bool orig_row # i: show row number from underlying table? +bool showhdr # i: print column names, etc? +bool showunits # i: print column units? +bool align # i: override print fmt to align col & name? +char sp_cname[SZ_COLNAME] # i: column to control spacing +int lgroup # i: print blank line after this many lines +char columns[ARB] # i: list of names of columns to be printed +char range_string[ARB] # i: range of row numbers to print +char prt_option[ARB] # i: "plain", "latex", or "tex" +#-- +pointer sp +pointer cptr # scratch for array of column pointers +pointer s_cp # pointer to column to control spacing +int nrows, ncols # number of rows and columns in table +int ncp # number of columns to print (may be < ncols) +int k # loop index +int tbpsta() + +begin + nrows = tbpsta (tp, TBL_NROWS) + ncols = tbpsta (tp, TBL_NCOLS) + + if ((nrows < 1) || (ncols < 1)) { + call eprintf ("table is empty\n") + return # nothing more to do + } + + # Allocate enough space for storing a descriptor for each column. + call smark (sp) + call salloc (cptr, ncols, TY_POINTER) + + # Get column pointers for all columns that are to be printed. + call tctexp (tp, columns, ncols, ncp, Memi[cptr]) + + # Check whether there is a column to control spacing. + k = 1 + while ((sp_cname[k] == ' ' || sp_cname[k] == '\t') && + (sp_cname[k] != EOS) && (k <= SZ_COLNAME)) + k = k + 1 + if (sp_cname[k] != EOS) { + call tbcfnd1 (tp, sp_cname[k], s_cp) + if (s_cp == NULL) { + call eprintf ("WARNING: column `%s' for spacing not found\n") + call pargstr (sp_cname) + } + } else { + s_cp = NULL + } + + if (ncp > 0) { + # Print the values in the table. + if (prt_option[1] == 'p') { # plain printing + call tpr_plain_pr (tp, Memi[cptr], ncp, s_cp, lgroup, + range_string, pagewidth, pagelength, + showrow, orig_row, showhdr, showunits, align) + } else if (prt_option[1] == 'h') { # html table + call tpr_html_pr (tp, Memi[cptr], ncp, s_cp, lgroup, + range_string, pagelength, + showrow, orig_row, showhdr, showunits) + } else { # LaTeX or TeX + call tpr_latex_pr (tp, Memi[cptr], ncp, s_cp, lgroup, + range_string, pagewidth, pagelength, + showrow, orig_row, showhdr, showunits, prt_option) + } + call flush (STDOUT) + } else { + call error (1, "column not found") + } + call sfree (sp) +end + + + +# tpr_space -- print line separator +# Check whether we should print a blank line (or other line separator) if +# the value in the designated column has changed since the last call to +# this routine or if a group of lgroup lines has been printed. +# The groups of lines are counted starting at the beginning of each +# page; this makes a difference if lgroup does not divide pagelength. +# If any column being printed contains arrays, then lgroup is applied +# to element number, not to line number. +# +# If lgroup is one then it will be ignored; if s_cp is NULL then +# the column values will be ignored. +# When linenum is zero, the "previous" column value is initialized +# with the current value. + +procedure tpr_space (tp, s_cp, lgroup, + rownum, element, max_nelem, pagelength, linenum, s_flag) + +pointer tp # i: pointer to table descriptor +pointer s_cp # i: pointer to column to control spacing +int lgroup # i: print blank after this many lines +int rownum # i: number of current row +int element # i: array element number +int max_nelem # i: max value for element +int pagelength # i: number of data lines per page +int linenum # i: number of lines that have been printed +int s_flag # o: YES if we should print a line for spacing +#-- +pointer sp +pointer current # scratch for value of column in current row +int lpage # number of lines already printed on this page +char previous[SZ_LINE] # value of column in previous row +bool do_compare # true if we should compare column values +bool strne() +int nelem, tbcigi(), junk, tbagtt() +errchk tbegtt, tbagtt + +begin + s_flag = NO # may be changed later + + if (lgroup <= 1 && s_cp == NULL) + return + + if (pagelength > 0) + lpage = mod (linenum, pagelength) + 1 + else + lpage = linenum + 1 + + if (s_cp != NULL) + nelem = tbcigi (s_cp, TBL_COL_LENDATA) + else + nelem = 1 + + # If we're at the beginning of a page, get the current value + # of the column and save it as "previous". That's all. + if (lpage == 1) { + if (s_cp != NULL) { + if (nelem > 1) { + if (element <= nelem) { + junk = tbagtt (tp, s_cp, rownum, previous, SZ_LINE, + element, 1) + } + } else { + call tbegtt (tp, s_cp, rownum, previous, SZ_LINE) + } + } + return + } + + # Have we printed a group of lines? If so, set the flag to indicate + # that we should print a blank line. + # If we're printing arrays, apply lgroup to the array elements instead + # of to the rows, but in this case also print a space between each row + # (i.e. when element is one), except at the top of a page. + # Note: The value of lgroup is one more than the parameter value, + # so that it can be used with mod on linenum, because linenum gets + # incremented when a blank line is printed. But here we want to use + # lgroup with element, which doesn't get incremented. That's why + # we subtract one from lgroup in "mod (element, lgroup-1)". + if (lgroup > 1) { + if (max_nelem > 1) { + if (lpage > 1) { + if (lgroup == 2) + s_flag = YES + else if (mod (element, lgroup-1) == 1) + s_flag = YES + } + } else if (mod (lpage, lgroup) == 0) { + s_flag = YES + } + } + + # Check the value in the column. + if (s_cp != NULL) { + if (s_flag == YES) { + # If we already know we need to print a space, we don't have + # to compare current and previous values, but we still must + # save current value as "previous". + if (nelem > 1 && element <= nelem) { + junk = tbagtt (tp, s_cp, rownum, previous, SZ_LINE, + element, 1) + } else if (element == 1) { + call tbegtt (tp, s_cp, rownum, previous, SZ_LINE) + } # else we already have the value + } else { + # Get current value, and compare it with previous value. + call smark (sp) + call salloc (current, SZ_LINE, TY_CHAR) + do_compare = true # may be reset + if (nelem > 1 && element <= nelem) { + junk = tbagtt (tp, s_cp, rownum, Memc[current], SZ_LINE, + element, 1) + } else if (element == 1) { + call tbegtt (tp, s_cp, rownum, Memc[current], SZ_LINE) + } else { + do_compare = false + } + if (do_compare && strne (Memc[current], previous)) { + # Set flag; save current value as previous value. + s_flag = YES + call strcpy (Memc[current], previous, SZ_LINE) + } + call sfree (sp) + } + } +end diff --git a/pkg/utilities/nttools/tprint/tprlatex.x b/pkg/utilities/nttools/tprint/tprlatex.x new file mode 100644 index 00000000..2875caa8 --- /dev/null +++ b/pkg/utilities/nttools/tprint/tprlatex.x @@ -0,0 +1,579 @@ +include +include "tprint.h" + +# tpr_latex_pr -- print contents of table +# This version prints the table data in a form suitable for input to +# TeX or LaTeX. The corresponding procedure that prints in plain text +# format is tpr_plain_pr. +# +# Phil Hodge, 7-Oct-1987 Subroutine created +# Phil Hodge, 12-Feb-1988 Call tpr_pfmt_l instead of tpr_pfmt +# Phil Hodge, 30-Mar-1988 Use a column to control spacing of printout. +# Phil Hodge, 6-Jan-1989 tpr_break_l for new page, also after tpr_cnames_pr. +# Phil Hodge, 2-Apr-1993 In prt_row_l, include short datatype. +# Phil Hodge, 5-Jul-1993 Include option to print column units. +# Phil Hodge, 26-Mar-1998 Add orig_row to calling sequence, use in prt_row_l; +# in tpr_break_l, the calling sequence of tpr_end_tbl +# had an extra argument. +# Phil Hodge, 9-Aug-1999 Change the calling sequence of tpr_space. + +procedure tpr_latex_pr (tp, colptr, ncp, s_cp, lgroup, + range_string, pagewidth, pagelength, + showrow, orig_row, showhdr, showunits, prt_option) + +pointer tp # i: pointer to table descriptor +pointer colptr[ncp] # i: array of pointers to column descriptors +int ncp # i: number of columns to print +pointer s_cp # i: pointer to column to control spacing +int lgroup # i: print a blank line after this many lines +char range_string[ARB] # i: string which gives ranges of row numbers +int pagewidth # i: page width +int pagelength # i: number of data lines per page +bool showrow # i: true if row number is to be printed +bool orig_row # i: show row number from underlying table? +bool showhdr # i: print column names, etc? +bool showunits # i: print column units? +char prt_option[ARB] # i: "latex" or "tex" +#-- +pointer sp +pointer data_fmt # print formats for column data values +pointer j_flag # left or right justification +char rn_fmt[SZ_FMT] # format for printing row numbers +char rn_name[SZ_ROW_HDR] # row number header: "(row)" +char percent # a percent sign (comment for TeX) +int nrows # total number of rows in table +int element # loop index for array element number +int max_nelem # max number of elements +int rn_width # width needed for printing row number +int lenfmt[MAXCOLS] # lengths of print fmt for cols on current page +int rownum # row number +int linenum # number of lines of data printed +int ranges[3,MAX_RANGES] # ranges of row numbers +int nvalues # returned by decode_ranges and ignored +int stat # returned by get_next_number +int k # loop index +int s_flag # YES if we should add a line for spacing +bool done # flag for terminating while loop on rows +int decode_ranges(), get_next_number(), tbpsta(), tbcigi() + +begin + percent = '%' + + # Allocate space for format strings for printing column names + # and values. + call smark (sp) + call salloc (data_fmt, (SZ_FMT+1)*ncp, TY_CHAR) + call salloc (j_flag, ncp, TY_INT) + + if (ncp > MAXCOLS) { + call eprintf ("maximum number of columns is %d\n") + call pargi (MAXCOLS) + call error (1, "") + } + + nrows = tbpsta (tp, TBL_NROWS) + + if (decode_ranges (range_string, ranges, MAX_RANGES, nvalues) != OK) + call error (1, "bad range of row numbers") + + # These three values (rn_name, rn_fmt, rn_width) must be consistent. + call strcpy ("(row)", rn_name, SHORT_STRING) + call strcpy ("%5d", rn_fmt, SZ_FMT) + if (showrow) + rn_width = SZ_ROW_HDR # space for printing row number + else + rn_width = 0 + + # Get length of print format for each column. + do k = 1, ncp + lenfmt[k] = tbcigi (colptr[k], TBL_COL_FMTLEN) + + # Fill array of print formats for column names and for data. + call tpr_pfmt_l (colptr, lenfmt, Memc[data_fmt], + Memi[j_flag], ncp) + + if (showhdr) { + # Print the \begin{document} string. + call tpr_beg_doc (prt_option) + + # Print the default \def or \newcommand for column separators + # and \eol, and print the begin-table string and column names. + call tpr_def (prt_option, ncp, showrow) + call tpr_begin_tbl (prt_option, Memi[j_flag], ncp, showrow) + call tpr_cnames_pr_l (colptr, ncp, showrow, showunits, rn_name) + } + + # Print each row that is to be printed. + linenum = 0 # initialize line counter + rownum = 0 # initialize get_next_number + stat = get_next_number (ranges, rownum) # get first row number + done = (stat == EOF) || (rownum > nrows) + + element = 1 # not used yet + max_nelem = 1 + + while ( !done ) { + + # Print a page break if appropriate. + call tpr_break_l (linenum, pagelength, showhdr, showunits, + prt_option, Memi[j_flag], + colptr, ncp, showrow, rn_name) + + # Print a blank line if the column value has changed or if + # a group of lgroup lines have been printed. + call tpr_space (tp, s_cp, lgroup, + rownum, element, max_nelem, pagelength, linenum, s_flag) + if (s_flag == YES) { + call printf ("\\extline\n") + linenum = linenum + 1 + # Check whether we should also print a page break. + call tpr_break_l (linenum, pagelength, showhdr, showunits, + prt_option, Memi[j_flag], + colptr, ncp, showrow, rn_name) + } + + # Print % as row separator (for readability); print current row. + call printf ("%c\n") + call pargc (percent) + call prt_row_l (tp, colptr, Memc[data_fmt], ncp, rownum, + lenfmt, pagewidth, showrow, orig_row, rn_fmt, rn_width) + linenum = linenum + 1 + stat = get_next_number (ranges, rownum) + done = (stat == EOF) || (rownum > nrows) + } + + if (showhdr) { + # Print end-table string. + call tpr_end_tbl (prt_option) + } + if (showhdr) + # Write \end{document} string. + call tpr_end_doc (prt_option) + + call sfree (sp) +end + +# tpr_break_l -- print a page break +# This routine prints the "end table" and "begin table" strings, if +# appropriate. If pagelength is zero we're not printing page breaks +# anyway, and if linenum is zero we've already printed the header, so +# nothing is done. Otherwise, if linenum is zero mod pagelength +# print a page break, and if showhdr print the column names. + +procedure tpr_break_l (linenum, pagelength, showhdr, showunits, + prt_option, just_flag, + colptr, ncp, showrow, rn_name) + +int linenum # io: number of lines of data printed +int pagelength # i: number of data lines per page +bool showhdr # i: print column names? +bool showunits # i: print column units? +char prt_option[ARB] # i: "latex" or "tex" +int just_flag[ARB] # i: -1, 0, +1 for left, center, right just. +pointer colptr[ARB] # i: array of column pointers +int ncp # i: number of columns to print +bool showrow # i: print row number? +char rn_name[ARB] # i: column header for row number +#-- + +begin + if (pagelength > 0) { + if (linenum > 0) { + if (mod (linenum, pagelength) == 0) { + # Print end table, begin table, and column names. + call tpr_end_tbl (prt_option) + call tpr_begin_tbl (prt_option, just_flag, ncp, + showrow) + if (showhdr) + call tpr_cnames_pr_l (colptr, ncp, + showrow, showunits, rn_name) + } + } + } +end + + +# tpr_pfmt_l -- Get print formats +# This procedure fills an array with print formats for printing the +# column values. An array of flags specifying whether each column is +# to be left or right justified is also returned. + +procedure tpr_pfmt_l (colptr, lenfmt, data_fmt, just_flag, ncp) + +pointer colptr[ncp] # i: array of column pointers +int lenfmt[ncp] # i: array of lengths of print formats +char data_fmt[SZ_FMT,ncp] # o: array of print formats for data +int just_flag[ncp] # o: -1 or +1 for left, right justification +int ncp # i: number of columns to print +#-- +int cn # loop index for column number + +begin + do cn = 1, ncp { # do for each column to print + + call tbcigt (colptr[cn], TBL_COL_FMT, data_fmt[1,cn], SZ_FMT) + if (data_fmt[2,cn] == '-') + just_flag[cn] = -1 # left justification + else + just_flag[cn] = 1 # right justification + } +end + + + +# tpr_beg_doc -- Print begin-document strings +# This procedure prints strings for LaTeX or for TeX that begin +# a document. (Nothing is written for TeX.) + +procedure tpr_beg_doc (prt_option) + +char prt_option[ARB] # i: "latex" or "tex" + +begin + if (prt_option[1] == 'l') { # LaTeX + call printf ("\\documentstyle{article}\n") + call printf ("\\begin{document}\n") + } +end + + + +# tpr_end_doc -- Print end-document strings +# This procedure prints strings for LaTeX or for TeX that end +# a document. + +procedure tpr_end_doc (prt_option) + +char prt_option[ARB] # i: "latex" or "tex" + +begin + if (prt_option[1] == 'l') # LaTeX + call printf ("\\end{document}\n") + else if (prt_option[1] == 't') # TeX + call printf ("\\end\n") +end + + +# tpr_def -- Print newcommand strings +# This procedure prints strings for LaTeX or for TeX that define +# macros for column separators and for the end-of-line string. +# +# Phil Hodge, 1-Apr-88 \extline added + +procedure tpr_def (prt_option, ncp, showrow) + +char prt_option[ARB] # i: "latex" or "tex" +int ncp # i: number of columns to print +bool showrow # i: print row number? +#-- +int k # loop index +char new_cmd[SHORT_STRING] # "\newcommand" or "\def" +char n_str[SHORT_STRING] # "{\null}" +char latex_eol[SHORT_STRING] # "\eol{\\}" +char tex_eol[SHORT_STRING] # "\eol{\cr}" + +begin + if (prt_option[1] == 'l') # LaTeX + call strcpy ("\\newcommand", new_cmd, SHORT_STRING) + else if (prt_option[1] == 't') # TeX + call strcpy ("\\def", new_cmd, SHORT_STRING) + call strcpy ("{\\null}", n_str, SHORT_STRING) + call strcpy ("\\eol{\\\\}", latex_eol, SHORT_STRING) + call strcpy ("\\eol{\\cr}", tex_eol, SHORT_STRING) + + if (showrow) + k = 0 + else + k = 1 + + # Define either \colzero or \cola, depending on showrow. + call printf ("%s") + call pargstr (new_cmd) + call tpr_w_colsep (k) + call printf ("%s\n") + call pargstr (n_str) + + # Define the rest of the column-separators, if any. + k = k + 1 + while (k <= ncp) { + call printf ("%s") + call pargstr (new_cmd) + call tpr_w_colsep (k) + call printf ("{&}\n") + k = k + 1 + } + + # Define \eol. + call printf ("%s") + call pargstr (new_cmd) + if (prt_option[1] == 'l') { # LaTeX + call printf ("%s\n") + call pargstr (latex_eol) + } else if (prt_option[1] == 't') { # TeX + call printf ("%s\n") + call pargstr (tex_eol) + } + + # Define \extline for writing blank lines. + call printf ("%s\\extline{") + call pargstr (new_cmd) + do k = 1, ncp-1 + call printf ("&") + if (showrow) + call printf ("&") + call printf ("\\eol}\n") + + call printf ("\n") +end + + + +# tpr_begin_tbl -- Print begin-table string +# This procedure prints a begin-table string for LaTeX or for TeX. + +procedure tpr_begin_tbl (prt_option, just_flag, ncp, showrow) + +char prt_option[ARB] # i: "latex" or "tex" +int just_flag[ARB] # i: -1, 0, +1 for left, center, right just. +int ncp # i: number of columns to print +bool showrow # i: print row number? +#-- +int k # loop index +char tex_cr[SHORT_STRING] # "\cr" + +begin + if (prt_option[1] == 'l') { # LaTeX + + call printf ("\\begin{tabular}{") + if (showrow) + call printf ("r") # right justify row number + do k = 1, ncp { + if (just_flag[k] == -1) + call printf ("l") # left justify + else if (just_flag[k] == 1) + call printf ("r") # right justify + else + call printf ("c") # center + } + call printf ("}\n") + + } else if (prt_option[1] == 't') { # TeX + + call strcpy ("\\cr", tex_cr, SHORT_STRING) + + if (showrow) { + call printf ("\\halign{\\hfil#") # row number + call printf ("\n&\\quad") + } else { + call printf ("\\halign{") + } + + # First column. + if (just_flag[1] == -1) + call printf ("#\\hfil") # left + else if (just_flag[1] == 1) + call printf ("\\hfil#") # right + else + call printf ("\\hfil#\\hfil") # center + + do k = 2, ncp { + if (just_flag[k] == -1) + call printf ("\n&\\quad#\\hfil") + else if (just_flag[k] == 1) + call printf ("\n&\\quad\\hfil#") + else + call printf ("\n&\\quad\\hfil#\\hfil") + } + call printf ("%s\n\n") # can't use \eol here + call pargstr (tex_cr) + } +end + + +# tpr_end_tbl -- Print end-table string +# This procedure prints an end-table string for LaTeX (or TeX). + +procedure tpr_end_tbl (prt_option) + +char prt_option[ARB] # i: "latex" or "tex" +#-- + +begin + if (prt_option[1] == 'l') # LaTeX + call printf ("\\end{tabular}\n\n") + else if (prt_option[1] == 't') # TeX + call printf ("}\n\n") +end + + + +# tpr_cnames_pr_l -- Print column names +# This procedure prints the column names followed by a blank line. +# (TeX or LaTeX only) + +procedure tpr_cnames_pr_l (colptr, ncp, showrow, showunits, rn_name) + +pointer colptr[ncp] # i: array of column pointers +int ncp # i: number of columns on current page +bool showrow # i: true if row number is to be printed +bool showunits # i: print column units? +char rn_name[ARB] # i: column header for row number +#-- +int cn # loop index for column number +char colname[SZ_COLNAME] # column name +char colunits[SZ_COLUNITS] # column units + +begin + if (showrow) { + call tpr_w_colsep (0) + call printf (rn_name) + } + do cn = 1, ncp { # do for each column on page + call tpr_w_colsep (cn) + call tbcigt (colptr[cn], TBL_COL_NAME, colname, SZ_COLNAME) + call printf ("%s") # trim extra blanks + call pargstr (colname) + } + call printf ("\\eol\n") + + # Also print column units? + if (showunits) { + if (showrow) { + call tpr_w_colsep (0) + } + do cn = 1, ncp { + call tpr_w_colsep (cn) + call tbcigt (colptr[cn], TBL_COL_UNITS, colunits, SZ_COLUNITS) + call printf ("%s") + call pargstr (colunits) + } + call printf ("\\eol\n") + } + call printf ("\\extline\n") +end + + +# prt_row_l -- print a row +# This procedure prints the contents of one row. This LaTeX (or TeX) +# version differs from the plain-print version in the following ways: +# character-string values are printed using %s so that extra blanks +# will not be printed, the column-separators may differ from one column +# to the next, and an end-of-line string is printed. + +procedure prt_row_l (tp, colptr, data_fmt, ncp, rownum, + lenfmt, pagewidth, showrow, orig_row, rn_fmt, rn_width) + +pointer tp # i: pointer to table descriptor +pointer colptr[ncp] # i: array of pointers to column descriptors +char data_fmt[SZ_FMT,ncp] # i: print format for each column +int ncp # i: number of columns on current page +int rownum # i: row number +int lenfmt[ncp] # i: array of lengths of print formats +int pagewidth # i: page width +bool showrow # i: print row number? +bool orig_row # i: show row number from underlying table? +char rn_fmt[ARB] # i: format for printing row number +int rn_width # i: space for printing row number +#-- +pointer sp +pointer cbuf # scratch for character-string buffer +double dbuf # buffer for double-precision elements +real rbuf # buffer for single-precision elements +int ibuf # buffer for integer elements +short sbuf +bool bbuf # buffer for boolean elements +int cn # loop index for column number +int datatype # data type of column +int lentotal # for determining when to print \n +int colsep_width # space needed to print column-separator string +int underlying_row # row number in underlying table +int tbcigi() +errchk tbsirow + +begin + call smark (sp) + call salloc (cbuf, SZ_LINE, TY_CHAR) + + colsep_width = 6 # e.g. "\cola " + + if (showrow) { + call tpr_w_colsep (0) + if (orig_row) { + call tbsirow (tp, rownum, underlying_row) + call printf (rn_fmt) + call pargi (underlying_row) + } else { + call printf (rn_fmt) + call pargi (rownum) # write row number + } + lentotal = colsep_width + rn_width + } else { + lentotal = 0 + } + + do cn = 1, ncp { + + if (lentotal + lenfmt[cn] > pagewidth) { + call printf ("\n") + lentotal = 0 + } + call tpr_w_colsep (cn) # write column-separator string + + datatype = tbcigi (colptr[cn], TBL_COL_DATATYPE) + switch (datatype) { + case (TY_REAL): + call tbegtr (tp, colptr[cn], rownum, rbuf) + call printf (data_fmt[1,cn]) + call pargr (rbuf) + case (TY_DOUBLE): + call tbegtd (tp, colptr[cn], rownum, dbuf) + call printf (data_fmt[1,cn]) + call pargd (dbuf) + case (TY_INT): + call tbegti (tp, colptr[cn], rownum, ibuf) + call printf (data_fmt[1,cn]) + call pargi (ibuf) + case (TY_SHORT): + call tbegts (tp, colptr[cn], rownum, sbuf) + call printf (data_fmt[1,cn]) + call pargs (sbuf) + case (TY_BOOL): + call tbegtb (tp, colptr[cn], rownum, bbuf) + call printf (data_fmt[1,cn]) + call pargb (bbuf) + default: + if (datatype < 0 || datatype == TY_CHAR) { + call tbegtt (tp, colptr[cn], rownum, Memc[cbuf], SZ_LINE) + call printf ("%s") # trim blanks + call pargstr (Memc[cbuf]) + } else { + call error (1, "bad data type; table corrupted?") + } + } + lentotal = lentotal + colsep_width + lenfmt[cn] + } + call printf ("\\eol\n") + + call sfree (sp) +end + + +# tpr_w_colsep -- Write column-separator string +# This procedure writes a string of the form "\cola ", "\colb ", etc +# for n = 1, 2, etc. The case n = 0 gives "\colzero " which is used +# for the row number column. + +procedure tpr_w_colsep (n) + +int n # i: column number or zero +#-- +string alphabet "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + +begin + if (n <= 0) { + call printf ("\\colzero ") + } else { + call printf ("\\col%c ") + call pargc (alphabet[n]) + } +end diff --git a/pkg/utilities/nttools/tprint/tprplain.x b/pkg/utilities/nttools/tprint/tprplain.x new file mode 100644 index 00000000..c40217d7 --- /dev/null +++ b/pkg/utilities/nttools/tprint/tprplain.x @@ -0,0 +1,530 @@ +include # for IS_WHITE +include +include "tprint.h" + +# tpr_plain_pr -- print contents of table +# This version simply prints the table data. The corresponding procedure +# that prints in TeX/LaTeX format is tpr_latex_pr. +# It may be that all the columns that are to be printed will not fit +# on one page, in which case they are printed in sections: all the rows +# are printed for the first set of columns, then all the rows for the next +# set, etc. +# +# Phil Hodge, 5-Oct-1987 Subroutine created +# Phil Hodge, 7-Oct-1987 prt_row: use different buffer for each data type. +# Phil Hodge, 12-Feb-1988 Include option to align columns with header +# Phil Hodge, 30-Mar-1988 Use a column to control spacing of printout. +# Phil Hodge, 6-Jan-1989 Call tpr_break for new page, also after tpr_cnames_pr +# Phil Hodge, 2-Apr-1993 In prt_row, include short datatype. +# Phil Hodge, 5-Jul-1993 Include option to print column units. +# Phil Hodge, 16-Feb-1995 Print "#" before header lines to comment them out. +# Phil Hodge, 26-Mar-1998 Add orig_row to calling sequence, use in prt_row; +# remove showrow from calling sequences of +# tpr_break and tpr_cnames_pr. +# Phil Hodge, 18-Jan-1999 Get boolean as string, to preserve indef values. +# Phil Hodge, 30-Mar-1999 Delete declaration of bbuf from prt_row. +# Phil Hodge, 9-Aug-1999 Print all array elements; +# move code for printing blank lines into prt_row; +# change the calling sequence of tpr_space; +# delete data_fmt and subroutine tpr_g_fmt. +# Phil Hodge, 3-Jul-2000 In tpr_pfmt, use "%-s" format for the last column +# on a page, if the column should be left justified. +# Phil Hodge, 2-Nov-2000 Remove the restriction that no more than MAXCOLS +# columns can be printed on one page. + +procedure tpr_plain_pr (tp, cptr, nprint, s_cp, lgroup, + range_string, pagewidth, pagelength, + showrow, orig_row, showhdr, showunits, align) + +pointer tp # i: pointer to table descriptor +pointer cptr[nprint] # i: array of pointers to column descriptors +int nprint # i: number of columns to print +pointer s_cp # i: pointer to column to control spacing +int lgroup # i: print blank line after this many lines +char range_string[ARB] # i: string which gives ranges of row numbers +int pagewidth # i: page width +int pagelength # i: number of data lines per page +bool showrow # i: true if row number is to be printed +bool orig_row # i: show row number from underlying table? +bool showhdr # i: print column names? +bool showunits # i: print column units? +bool align # i: override print fmt to align col & name? +#-- +pointer sp +pointer colptr # ptr to descriptors for columns on current page +pointer lenfmt # ptr to lengths of print fmt for cols on page +pointer cn_fmt # formats for printing column values +char rn_fmt[SZ_FMT] # format for printing row numbers +char rn_name[SZ_ROW_HDR] # row number header: "# row" +char rn_units[SZ_ROW_HDR] # "# " printed in the line for units +char percent # '%' +int nrows # total number of rows in table +int rn_width # width needed for printing row number +int lcp # column number of leftmost column on page +int ncp # number of columns on current page +int rownum # row number +int linenum # number of lines of data printed +int ranges[3,MAX_RANGES] # ranges of row numbers +int nvalues # returned by decode_ranges and ignored +int stat # returned by get_next_number +bool done # flag for terminating while loop on rows +int decode_ranges(), get_next_number(), tbpsta() + +begin + # Allocate space for format strings for printing column names and + # values. Allocate arrays for pointers to column descriptors and + # the ascii width of each column. Allow enough space to print all + # columns on one page. + call smark (sp) + call salloc (cn_fmt, (SZ_FMT+1)*nprint, TY_CHAR) + call salloc (colptr, nprint, TY_POINTER) + call salloc (lenfmt, nprint, TY_POINTER) + + nrows = tbpsta (tp, TBL_NROWS) + + if (decode_ranges (range_string, ranges, MAX_RANGES, nvalues) != OK) + call error (1, "bad range of row numbers") + + # rn_name, rn_units, rn_fmt and rn_width must be consistent. + if (showrow) { + # These two strings are printed above the row number + # in the line for column names and in the line for column units. + call strcpy ("# row", rn_name, SZ_ROW_HDR) + call strcpy ("# ", rn_units, SZ_ROW_HDR) + rn_width = SZ_ROW_HDR # space for printing row number + } else if (showhdr) { + call strcpy ("#", rn_name, SZ_ROW_HDR) + call strcpy ("#", rn_units, SZ_ROW_HDR) + rn_width = 1 # space for "#" + } else { + rn_name[1] = EOS # no header printed + rn_units[1] = EOS + rn_width = 0 + } + percent = '%' + call sprintf (rn_fmt, SZ_FMT, "%c%dd") # --> %5d + call pargc (percent) + call pargi (SZ_ROW_HDR) + + lcp = 1 # initialize + while (lcp <= nprint) { # do for each page + + # Get column pointers for current page + call get_page (tp, cptr, lcp, nprint, pagewidth-rn_width, + align, showunits, Memi[colptr], Memi[lenfmt], ncp) + + # Fill array of print formats. + call tpr_pfmt (Memi[colptr], Memi[lenfmt], align, Memc[cn_fmt], ncp) + + # Print a form feed if this is not the first page and the user + # has requested page breaks. + if (lcp > 1) { + if (pagelength > 0) + call printf ("\f\n") + else + call printf ("\n") + } + # Print column names. + if (showhdr) + call tpr_cnames_pr (Memi[colptr], Memc[cn_fmt], ncp, + showunits, rn_name, rn_units) + + # Print each row that is to be printed. + linenum = 0 # initialize line counter + rownum = 0 # initialize get_next_number + stat = get_next_number (ranges, rownum) # get first row number + done = (stat == EOF) || (rownum > nrows) + + while ( !done ) { + + # Print values in current row. + call prt_row (tp, Memi[colptr], Memc[cn_fmt], ncp, + linenum, pagelength, s_cp, lgroup, + rn_fmt, rn_name, rn_units, + rownum, showrow, orig_row, showhdr, showunits) + + # Get next row number. + stat = get_next_number (ranges, rownum) + done = (stat == EOF) || (rownum > nrows) + } + + lcp = lcp + ncp # next set of columns to be printed + } + call sfree (sp) +end + +# tpr_break -- print a page break +# This routine prints a form feed ('\f') if appropriate. If pagelength +# is zero we're not printing page breaks anyway, and if linenum is zero +# we've already printed the header, so nothing is done. Otherwise, +# if linenum is zero mod pagelength print a page break, and if showhdr +# print the header. + +procedure tpr_break (linenum, pagelength, showhdr, showunits, + colptr, cn_fmt, ncp, rn_name, rn_units) + +int linenum # io: number of lines of data printed +int pagelength # i: number of data lines per page +bool showhdr # i: print column names? +bool showunits # i: also print column units? +pointer colptr[ARB] # i: array of column pointers +char cn_fmt[SZ_FMT,ARB] # i: array of print formats +int ncp # i: number of columns on current page +char rn_name[ARB] # i: column header for row number +char rn_units[ARB] # i: printed below rn_name +#-- + +begin + if (pagelength > 0) { + if (linenum > 0) { + if (mod (linenum, pagelength) == 0) { + call printf ("\f\n") + if (showhdr) # print column names + call tpr_cnames_pr (colptr, cn_fmt, ncp, + showunits, rn_name, rn_units) + } + } + } +end + + +# get_page -- get columns for page +# This procedure determines which columns will fit on the current page. +# Each column is assumed to begin with a column separator which is a +# single space. + +procedure get_page (tp, cptr, lcp, nprint, pagewidth, align, + showunits, colptr, lenfmt, ncp) + +pointer tp # i: pointer to table descriptor +pointer cptr[nprint] # i: array of pointers to all column descr +int lcp # i: column number of leftmost column on page +int nprint # i: number of columns to print +int pagewidth # i: page width available for writing +bool align # i: override print fmt to align col & name? +bool showunits # i: also print column units? +pointer colptr[ARB] # o: pointers for columns on current page +int lenfmt[ARB] # o: length of print format for each col +int ncp # o: number of columns on current page +#-- +char colname[SZ_COLNAME] # column name for error message +int lentotal # sum of lenfmt plus a space for each column +int nextc # column counter +int tpr_lenfmt() + +begin + # Assume we can print at least one column, truncated if necessary. + ncp = 1 + colptr[1] = cptr[lcp] + # Get width for printing column. + lenfmt[1] = tpr_lenfmt (colptr[1], align, showunits) + if (lenfmt[1] > pagewidth-1) { + call tbcigt (colptr[1], TBL_COL_NAME, colname, SZ_COLNAME) + call eprintf ("caution: column %s will be truncated\n") + call pargstr (colname) + lenfmt[1] = pagewidth-1 + } + + lentotal = lenfmt[1] + 1 # add one for leading space + + # The loop continuation conditions are: + # the columns fit on the page, + # there are still columns that have not been included. + while (lentotal < pagewidth && lcp+ncp-1 < nprint) { + nextc = ncp + 1 + colptr[nextc] = cptr[lcp+nextc-1] + # get lenfmt + lenfmt[nextc] = tpr_lenfmt (colptr[nextc], align, showunits) + lentotal = lentotal + lenfmt[nextc] + 1 # one for leading space + if (lentotal <= pagewidth) + ncp = nextc # = ncp + 1 + } +end + + + +# tpr_lenfmt -- get length of print format +# This function returns the length of the print format for a column. +# If align is true then the column name will be gotten, and the length +# of the print format that is returned will be at least as large as +# the length of the column name. The length will also be at least five, +# since that is the length of the word INDEF. + +int procedure tpr_lenfmt (cptr, align, showunits) + +pointer cptr # i: pointer to column descriptor +bool align # i: true ==> may increase length of print fmt +bool showunits # i: also print column units? +#-- +char colname[SZ_COLNAME] # name of column +char colunits[SZ_COLUNITS] # column units +int lenfmt # length of print format +int len_name # length of column name +int len_units # length of column units +int tbcigi(), strlen() + +begin + lenfmt = tbcigi (cptr, TBL_COL_FMTLEN) + + if ( align ) { + + call tbcigt (cptr, TBL_COL_NAME, colname, SZ_COLNAME) + len_name = strlen (colname) + + # Length >= length of column name or the word "INDEF". + lenfmt = max (lenfmt, len_name, 5) + + if (showunits) { + call tbcigt (cptr, TBL_COL_UNITS, colunits, SZ_COLUNITS) + len_units = strlen (colunits) + lenfmt = max (lenfmt, len_units) + } + } + return (lenfmt) +end + + + +# tpr_pfmt -- Get print formats +# This procedure fills an array with print formats of the form %ws. +# These can be used for printing the column names, units and data values. + +procedure tpr_pfmt (colptr, lenfmt, align, cn_fmt, ncp) + +pointer colptr[ncp] # i: array of column pointers +int lenfmt[ncp] # i: array of lengths of print formats +bool align # i: override print fmt to align col & name? +char cn_fmt[SZ_FMT,ncp] # o: array of print formats +int ncp # i: number of columns on current page +#-- +char fmt[SZ_COLFMT] # unmodified print format as gotten from table +int cn # loop index for column number + +begin + do cn = 1, ncp { # do for each column on page + + # Get print format for current column. + call tbcigt (colptr[cn], TBL_COL_FMT, fmt, SZ_COLFMT) + + cn_fmt[1,cn] = '%' + if (fmt[2] == '-') { # left justification + if (cn == ncp) { + call sprintf (cn_fmt[2,cn], SZ_FMT-1, "-s") + } else { + call sprintf (cn_fmt[2,cn], SZ_FMT-1, "-%ds") + call pargi (lenfmt[cn]) + } + } else { # right justification + call sprintf (cn_fmt[2,cn], SZ_FMT-1, "%ds") + call pargi (lenfmt[cn]) + } + } +end + + +# tpr_cnames_pr -- Print column names +# This procedure prints the column names and units and an extra blank line. +# A comment character ("#") is printed at the beginning of the line; this +# is new as of 1995 Feb 16. + +procedure tpr_cnames_pr (colptr, cn_fmt, ncp, + showunits, rn_name, rn_units) + +pointer colptr[ncp] # i: array of column pointers +char cn_fmt[SZ_FMT,ncp] # i: array of print formats +int ncp # i: number of columns on current page +bool showunits # i: also print column units? +char rn_name[ARB] # i: column header for row number +char rn_units[ARB] # i: printed below rn_name +#-- +char colname[SZ_COLNAME] # column name +char colunits[SZ_COLUNITS] # column units +int cn # loop index for column number + +begin + call printf (rn_name) # "# row" or "#" + + do cn = 1, ncp { # do for each column on page + call printf (" ") + call tbcigt (colptr[cn], TBL_COL_NAME, colname, SZ_COLNAME) + call printf (cn_fmt[1,cn]) + call pargstr (colname) + } + call printf ("\n") + + # Also print column units? + if (showunits) { + call printf (rn_units) # "# " or "#" + do cn = 1, ncp { + call printf (" ") + call tbcigt (colptr[cn], TBL_COL_UNITS, colunits, SZ_COLUNITS) + call printf (cn_fmt[1,cn]) + call pargstr (colunits) + } + call printf ("\n") + } + + call printf ("\n") +end + + +# prt_row -- print a row +# This procedure prints the contents of one row. + +procedure prt_row (tp, colptr, cn_fmt, ncp, + linenum, pagelength, s_cp, lgroup, + rn_fmt, rn_name, rn_units, + rownum, showrow, orig_row, showhdr, showunits) + +pointer tp # i: pointer to table descriptor +pointer colptr[ncp] # i: array of pointers to column descriptors +char cn_fmt[SZ_FMT,ncp] # i: array of print formats +int ncp # i: number of columns on current page +int linenum # io: number of lines of data printed +int pagelength # i: number of data lines per page +pointer s_cp # i: pointer to column to control spacing +int lgroup # i: print blank line after this many lines +char rn_fmt[ARB] # i: format for printing row number +char rn_name[ARB] # i: row number header: "# row" +char rn_units[ARB] # i: "# " printed in the line for units +int rownum # i: row number +bool showrow # i: print row number? +bool orig_row # i: show row number from underlying table? +bool showhdr # i: was a header printed? +bool showunits # i: print column units? +#-- +pointer sp +pointer cbuf # scratch for character-string buffer +pointer nelem # array length for each column +int max_nelem # maximum of array lengths +bool has_arrays # true if any column contains arrays +bool has_scalars # true if not all columns contain arrays +int cn # loop index for column number +int element # loop index for array element number +int underlying_row # row number in underlying table +int ip # first non-blank character in cbuf +int s_flag # YES if we should print a line for spacing +int tbcigi(), tbagtt() +errchk tbsirow + +begin + call smark (sp) + call salloc (cbuf, SZ_LINE, TY_CHAR) + call salloc (nelem, ncp, TY_INT) + + # Get the array length for each column. + max_nelem = 1 # initial values + if (showrow) + has_scalars = true # row number is a scalar + else + has_scalars = false + + do cn = 1, ncp { + Memi[nelem+cn-1] = tbcigi (colptr[cn], TBL_COL_LENDATA) + if (Memi[nelem+cn-1] > max_nelem) + max_nelem = Memi[nelem+cn-1] + if (Memi[nelem+cn-1] == 1) + has_scalars = true + } + has_arrays = (max_nelem > 1) + + # If all columns contain arrays, print a blank line as a separator. + if (!has_scalars && rownum > 1) + call printf ("\n") + + # Loop over the number of elements in the longest array. + do element = 1, max_nelem { + + # Print a page break if appropriate. + call tpr_break (linenum, pagelength, showhdr, showunits, + colptr, cn_fmt, ncp, rn_name, rn_units) + + # Print a blank line if the value in the column has changed + # or if a group of lgroup lines has been printed. + call tpr_space (tp, s_cp, lgroup, + rownum, element, max_nelem, pagelength, linenum, s_flag) + if (s_flag == YES) { + call printf ("\n") + linenum = linenum + 1 + # Check whether we should also print a page break. + call tpr_break (linenum, pagelength, showhdr, showunits, + colptr, cn_fmt, ncp, rn_name, rn_units) + } + + if (showrow) { + if (element == 1) { + if (orig_row) { + call tbsirow (tp, rownum, underlying_row) + call printf (rn_fmt) + call pargi (underlying_row) + } else { + call printf (rn_fmt) + call pargi (rownum) + } + } else { + call printf (" ") # SZ_ROW_HDR blanks + } + } else if (showhdr) { + # Corresponds to the "#" at the beginning of header lines. + call printf (" ") + } + + do cn = 1, ncp { + + # Even if no row number is printed, start with a space. + call printf (" ") # space between columns + + # Does the current column contain arrays? + if (Memi[nelem+cn-1] > 1) { + + if (element <= Memi[nelem+cn-1]) { + if (tbagtt (tp, colptr[cn], rownum, + Memc[cbuf], SZ_LINE, element, 1) < 1) + call error (1, "can't read array element") + call tpr_noblank (Memc[cbuf], ip) + } else { + Memc[cbuf] = EOS + ip = 1 + } + call printf (cn_fmt[1,cn]) + call pargstr (Memc[cbuf+ip-1]) + + } else if (element == 1) { + + # This is a scalar column. + call tbegtt (tp, colptr[cn], rownum, Memc[cbuf], SZ_LINE) + call tpr_noblank (Memc[cbuf], ip) + call printf (cn_fmt[1,cn]) + call pargstr (Memc[cbuf+ip-1]) + + } else { + + # Print a blank field for a scalar column to match array + # element > 1 for array column(s). + call printf (cn_fmt[1,cn]) + call pargstr ("") + } + } + call printf ("\n") + linenum = linenum + 1 + } + call sfree (sp) +end + +procedure tpr_noblank (buf, ip) + +char buf[ARB] # io: input string (trailing blanks will be truncted) +int ip # o: first non-blank character in buf +#-- +int strlen() + +begin + ip = strlen (buf) + while (ip >= 1 && IS_WHITE(buf[ip])) { # trim trailing blanks + buf[ip] = EOS + ip = ip - 1 + } + ip = 1 + while (IS_WHITE(buf[ip])) # trim leading blanks + ip = ip + 1 +end diff --git a/pkg/utilities/nttools/tproduct.par b/pkg/utilities/nttools/tproduct.par new file mode 100644 index 00000000..4159aac9 --- /dev/null +++ b/pkg/utilities/nttools/tproduct.par @@ -0,0 +1,4 @@ +intable1,f,a,,,,the first input table +intable2,f,a,,,,the second input table +outtable,s,a,,,,the output table +mode,s,h,"a",,, diff --git a/pkg/utilities/nttools/tproduct/mkpkg b/pkg/utilities/nttools/tproduct/mkpkg new file mode 100644 index 00000000..408be9e5 --- /dev/null +++ b/pkg/utilities/nttools/tproduct/mkpkg @@ -0,0 +1,11 @@ +# Update the tproduct application code in the ttools package library +# Author: B.Simon, 25-NOV-1987 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + tproduct.x + ; diff --git a/pkg/utilities/nttools/tproduct/tproduct.x b/pkg/utilities/nttools/tproduct/tproduct.x new file mode 100644 index 00000000..e9ec3ba8 --- /dev/null +++ b/pkg/utilities/nttools/tproduct/tproduct.x @@ -0,0 +1,113 @@ +include + +# TPRODUCT -- Form the cartesian product of two tables +# +# B.Simon 05-Nov-1987 First Code +# B.Simon 31-Mar-1992 Set output table type from input tables +# Phil Hodge 8-Apr-1999 Call tbfpri. + +procedure t_product() + +pointer intable1 # Names of the first table to be joined +pointer intable2 # Names of the second table to be joined +pointer outtable # Name of output table +#-- +int idx, jdx, kdx, icol, ncol1, ncol2, nrow1, nrow2, numcol, type1, type2 +int phu_copied # set by tbfpri and ignored +int colnum[1], datatype[1], lendata[1], lenfmt[1] +pointer sp, tp1, tp2, otp, icp, ocp, oldcol, newcol +pointer colname, colunits, colfmt + +int tbpsta(), tbcnum() +pointer tbtopn() + +begin + # Allocate stack memory for strings + + call smark (sp) + call salloc (intable1, SZ_FNAME, TY_CHAR) + call salloc (intable2, SZ_FNAME, TY_CHAR) + call salloc (outtable, SZ_FNAME, TY_CHAR) + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (colunits, SZ_COLUNITS, TY_CHAR) + call salloc (colfmt, SZ_COLFMT, TY_CHAR) + + # Read the task parameters + + call clgstr ("intable1", Memc[intable1], SZ_FNAME) + call clgstr ("intable2", Memc[intable2], SZ_FNAME) + call clgstr ("outtable", Memc[outtable], SZ_FNAME) + + # Open the tables + + tp1 = tbtopn (Memc[intable1], READ_ONLY, NULL) + tp2 = tbtopn (Memc[intable2], READ_ONLY, NULL) + call tbfpri (Memc[intable1], Memc[outtable], phu_copied) + otp = tbtopn (Memc[outtable], NEW_FILE, NULL) + + # Set type of output table + + type1 = tbpsta (tp1, TBL_WHTYPE) + type2 = tbpsta (tp2, TBL_WHTYPE) + if (type1 == type2) + call tbpset (otp, TBL_WHTYPE, type1) + + # Get the number of columns and allocate arrays to hold column pointers + + ncol1 = tbpsta (tp1, TBL_NCOLS) + ncol2 = tbpsta (tp2, TBL_NCOLS) + nrow1 = tbpsta (tp1, TBL_NROWS) + nrow2 = tbpsta (tp2, TBL_NROWS) + + numcol = ncol1 + ncol2 + call malloc (oldcol, numcol, TY_INT) + call malloc (newcol, numcol, TY_INT) + + # Copy column pointers to old column array. + + do icol = 1, ncol1 + Memi[oldcol+icol-1] = tbcnum (tp1, icol) + + do icol = 1, ncol2 + Memi[oldcol+ncol1+icol-1] = tbcnum (tp2, icol) + + # Copy column information from the input tables to the output table + + do icol = 1, numcol { + icp = Memi[oldcol+icol-1] + call tbcinf (icp, colnum, Memc[colname], Memc[colunits], + Memc[colfmt], datatype[1], lendata[1], lenfmt[1]) + call newcolnam (numcol, Memi[oldcol], icol, + Memc[colname], SZ_COLNAME) + call tbcdef (otp, ocp, Memc[colname], Memc[colunits], Memc[colfmt], + datatype[1], lendata[1], 1) + Memi[newcol+icol-1] = ocp + } + + # Copy the table columns a row at a time + + call tbtcre (otp) + call tbhcal (tp2, otp) + call tbhcal (tp1, otp) + + kdx = 0 + do idx = 1, nrow1 { + do jdx = 1, nrow2 { + kdx = kdx + 1 + call tbrcsc (tp1, otp, Memi[oldcol], Memi[newcol], + idx, kdx, ncol1) + call tbrcsc (tp2, otp, Memi[oldcol+ncol1], Memi[newcol+ncol1], + jdx, kdx, ncol2) + } + } + + # Close the tables and free dynamic memory + + call tbtclo (tp1) + call tbtclo (tp2) + call tbtclo (otp) + + call mfree (oldcol, TY_INT) + call mfree (newcol, TY_INT) + +end diff --git a/pkg/utilities/nttools/tproject.par b/pkg/utilities/nttools/tproject.par new file mode 100644 index 00000000..4edb65b2 --- /dev/null +++ b/pkg/utilities/nttools/tproject.par @@ -0,0 +1,5 @@ +intable,s,a,,,,"Input tables" +outtable,s,a,,,,"Output tables" +columns,s,a,,,,"Column names" +uniq,b,h,no,,,"Unique rows?" +mode,s,h,"a",,, diff --git a/pkg/utilities/nttools/tproject/mkpkg b/pkg/utilities/nttools/tproject/mkpkg new file mode 100644 index 00000000..f7c30ad4 --- /dev/null +++ b/pkg/utilities/nttools/tproject/mkpkg @@ -0,0 +1,13 @@ +# Update the tproject application code in the ttools package library +# Author: B.Simon, 25-NOV-1987 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + nextuniq.x + tproject.x + wproject.x + ; diff --git a/pkg/utilities/nttools/tproject/nextuniq.x b/pkg/utilities/nttools/tproject/nextuniq.x new file mode 100644 index 00000000..2a2b8e8d --- /dev/null +++ b/pkg/utilities/nttools/tproject/nextuniq.x @@ -0,0 +1,39 @@ +include + +# NEXTUNIQ -- Retrieve the next unique row from a table + +procedure nextuniq (tp, numptr, colptr, irow) + +pointer tp # i: Table descriptor +int numptr # i: Number of column pointers +pointer colptr[ARB] # i: Array of column pointers +int irow # u: Current unique row +#-- +bool fold +int jrow, krow, nrow + +data fold / false / + +int tbpsta(), tbrcmp() + +begin + # Get number of rows in table + + nrow = tbpsta (tp, TBL_NROWS) + + # Loop until a row that does not match the preceding rows is found + + for (jrow = irow+1; jrow <= nrow; jrow = jrow + 1) { + for (krow = 1; krow < jrow; krow = krow + 1) { + if (tbrcmp (tp, numptr, colptr, fold, jrow, krow) == 0) + break + } + + if (krow == jrow) + break + } + + # Set irow to the first row that does not match any preceding row + + irow = jrow +end diff --git a/pkg/utilities/nttools/tproject/tproject.x b/pkg/utilities/nttools/tproject/tproject.x new file mode 100644 index 00000000..6f74e272 --- /dev/null +++ b/pkg/utilities/nttools/tproject/tproject.x @@ -0,0 +1,100 @@ +include # for F_REDIR +include + +# T_PROJECT -- Create a new table from selected columns of an old table +# +# B.Simon 20-Oct-1987 First Code +# Phil Hodge 07-Sep-1988 Change parameter names for tables. +# B.Simon 31-Mar-1992 Set output table type from input table +# Phil Hodge 4-Oct-1995 Use table name template routines tbnopenp, etc. +# Phil Hodge 8-Apr-1999 Call tbfpri. +# B.Simon 30-Apr-1999 Replace call to unique with nextuniq +# Phil Hodge 9-Jun-1999 Set input/output to STDIN/STDOUT if redirected. + +procedure t_project() + +pointer ilist # Input table name template +pointer olist # Output table name template +pointer columns # Table column template +bool uniq # Should output rows be unique? +#-- +int junk, numcol, numptr, type +int phu_copied # set by tbfpri and ignored +pointer sp, itp, otp, intable, outtable, colptr + +string nomatch "Number of input tables must match output tables" +string notfound "Column(s) not found in table" + +bool clgetb() +int fstati() +int tbnget(), tbnlen(), tbpsta() +pointer tbtopn(), tbnopenp(), tbnopen() + +begin + # Allocate stack memory for strings + + call smark (sp) + call salloc (intable, SZ_FNAME, TY_CHAR) + call salloc (outtable, SZ_FNAME, TY_CHAR) + call salloc (columns, SZ_LINE, TY_CHAR) + + # Read the task parameters + + if (fstati (STDIN, F_REDIR) == YES) + ilist = tbnopen ("STDIN") + else + ilist = tbnopenp ("intable") + + if (fstati (STDOUT, F_REDIR) == YES) + olist = tbnopen ("STDOUT") + else + olist = tbnopenp ("outtable") + + call clgstr ("columns", Memc[columns], SZ_LINE) + uniq = clgetb ("uniq") + + # Loop over all table names in the input file name template + + if (tbnlen (ilist) != tbnlen (olist)) + call error (1, nomatch) + + while (tbnget (ilist, Memc[intable], SZ_FNAME) != EOF) { + + junk = tbnget (olist, Memc[outtable], SZ_FNAME) + + # Open the tables and set output table type + + itp = tbtopn (Memc[intable], READ_ONLY, NULL) + call tbfpri (Memc[intable], Memc[outtable], phu_copied) + otp = tbtopn (Memc[outtable], NEW_FILE, NULL) + + type = tbpsta (itp, TBL_WHTYPE) + call tbpset (otp, TBL_WHTYPE, type) + + # Create an array of column pointers from the column template + + numcol = tbpsta (itp, TBL_NCOLS) + call malloc (colptr, numcol, TY_INT) + + call tctexp (itp, Memc[columns], numcol, numptr, Memi[colptr]) + + if (numptr == 0) + call error (1, notfound) + + # Copy header and selected columns to output table + + call wproject (itp, otp, numptr, Memi[colptr], uniq) + + # Close the tables and free dynamic memory + + call tbtclo (itp) + call tbtclo (otp) + call mfree (colptr, TY_INT) + } + + # Close the filename template lists + + call tbnclose (ilist) + call tbnclose (olist) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tproject/wproject.x b/pkg/utilities/nttools/tproject/wproject.x new file mode 100644 index 00000000..176032ab --- /dev/null +++ b/pkg/utilities/nttools/tproject/wproject.x @@ -0,0 +1,64 @@ +include + +# WPROJECT -- Copy selected columns and rows to output table +# +# B.Simon 19-Oct-87 First Code +# B.Simon 30-Apr-1999 Replace call to unique with nextuniq + +procedure wproject (itp, otp, numptr, colptr, uniq) + +pointer itp # i: Input table descriptor +pointer otp # i: Output table descriptor +int numptr # i: Number of column pointers +pointer colptr[ARB] # i: Array of column pointers +bool uniq # i: Only output unique rows? +#-- +int iptr, irow, jrow, nrow +int colnum[1], datatype[1], lendata[1], lenfmt[1] +pointer sp, ocp, newcol, colname, colunits, colfmt + +int tbpsta() + +begin + # Set up arrays in dynamic memory + + call smark (sp) + call salloc (newcol, numptr, TY_INT) + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (colunits, SZ_COLUNITS, TY_CHAR) + call salloc (colfmt, SZ_COLFMT, TY_CHAR) + + + # Copy column information from the input table to the output table + + do iptr = 1, numptr { + call tbcinf (colptr[iptr], colnum, Memc[colname], Memc[colunits], + Memc[colfmt], datatype[1], lendata[1], lenfmt[1]) + call tbcdef (otp, ocp, Memc[colname], Memc[colunits], Memc[colfmt], + datatype[1], lendata[1], 1) + Memi[newcol+iptr-1] = ocp + } + + # Copy the table columns a row at a time + + call tbtcre (otp) + call tbhcal (itp, otp) + + irow = 1 + jrow = 1 + nrow = tbpsta (itp, TBL_NROWS) + + while (irow <= nrow) { + call tbrcsc (itp, otp, colptr, Memi[newcol], irow, jrow, numptr) + + if (uniq) { + call nextuniq (itp, numptr, colptr, irow) + } else { + irow = irow + 1 + } + + jrow = jrow + 1 + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tquery.par b/pkg/utilities/nttools/tquery.par new file mode 100644 index 00000000..927b5872 --- /dev/null +++ b/pkg/utilities/nttools/tquery.par @@ -0,0 +1,9 @@ +intable,s,a,,,,"Input tables" +outtable,s,a,,,,"Output tables" +expr,s,a," ",,,"Expression used for selection" +columns,s,a," ",,,"Column names" +sort,s,a," ",,,"Columns to sort on" +uniq,b,h,no,,,"Unique rows?" +ascend,b,h,yes,,,"Ascending order?" +casesens,b,h,yes,,,"Case sensitive sort?" +mode,s,h,"a",,, diff --git a/pkg/utilities/nttools/tquery/doquery.x b/pkg/utilities/nttools/tquery/doquery.x new file mode 100644 index 00000000..8dfc4cd4 --- /dev/null +++ b/pkg/utilities/nttools/tquery/doquery.x @@ -0,0 +1,72 @@ +define SYNTAX 1 + +# DOQUERY -- Perform a query on a table and return row and column arrays +# +# B.Simon 18-Dec-1987 First Code +# B.Simon 10-Aug-1992 Fixed calling sequence to tbl_sort +# Phil Hodge 18-Aug-2003 Call select before calling unique. + +procedure doquery (tp, expr, columns, sort, uniq, ascend, casesens, + numcol, colptr, nindex, index) + +int tp # i: Input table descriptor +char expr[ARB] # i: Expression used to select rows +char columns[ARB] # i: Table column template +char sort[ARB] # i: Sort columns template +bool uniq # i: Should output rows be unique? +bool ascend # i: Ascending sort flag +bool casesens # i: Case sensitivity flag +int numcol # io: Number of column pointers +pointer colptr[ARB] # io: Array of column pointers +int nindex # io: Number of row indices +int index[ARB] # io: Array of row indices +#-- +int numptr, numsort +pointer sortptr + +string nocolumn "Column names not found in table" +string nosort "Sort column not found in table" + +bool isblank() + +begin + + # Create an array of column pointers from the column template + + call tctexp (tp, columns, numcol, numptr, colptr) + + if (numptr == 0) + call error (SYNTAX, nocolumn) + + # Select rows according to expression + + if (! isblank(expr)) { + call select (tp, expr, nindex, index) + } + + # Remove duplicate rows from table + + if (uniq) + call unique (tp, numptr, colptr, nindex, index) + + # Sort the array of indices + + if (! isblank(sort)) { + + # Create an array of sort column pointers from the sort template + + call malloc (sortptr, numcol, TY_INT) + call tctexp (tp, sort, numcol, numsort, Memi[sortptr]) + + if (numsort == 0) + call error (SYNTAX, nosort) + + call tbl_sort (ascend, casesens, tp, numsort, Memi[sortptr], + nindex, index) + + call mfree (sortptr, TY_INT) + } + + numcol = numptr + +end diff --git a/pkg/utilities/nttools/tquery/mkpkg b/pkg/utilities/nttools/tquery/mkpkg new file mode 100644 index 00000000..ca5773d7 --- /dev/null +++ b/pkg/utilities/nttools/tquery/mkpkg @@ -0,0 +1,13 @@ +# Update the tquery application code in the ttools package library +# Author: B.Simon, 21-DEC-87 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + doquery.x + tquery.x + wquery.x + ; diff --git a/pkg/utilities/nttools/tquery/tquery.x b/pkg/utilities/nttools/tquery/tquery.x new file mode 100644 index 00000000..b7fc91b4 --- /dev/null +++ b/pkg/utilities/nttools/tquery/tquery.x @@ -0,0 +1,113 @@ +include # to check for I/O redirection +include + +define SYNTAX 1 + +# TQUERY -- Create a new table from selected rows and columns of an old table +# +# B.Simon 18-Dec-1987 First Code +# Phil Hodge 07-Sep-1988 Change parameter names for tables. +# B.Simon 31-Mar-1992 Set output table type from input table +# Phil Hodge 4-Oct-1995 Use table name template routines tbnopenp, etc. +# Phil Hodge 8-Apr-1999 Call tbfpri. +# Phil Hodge 9-Jun-1999 Set input/output to STDIN/STDOUT if redirected. + +procedure t_tquery() + +pointer ilist # Input table name template +pointer olist # Output table name template +pointer expr # Expression used to select rows +pointer columns # Table column template +pointer sort # Sort columns template +bool uniq # Should output rows be unique? +bool ascend # Ascending sort flag +bool casesens # Case sensitivity flag +#-- +int junk, nindex, numcol, type +int phu_copied # set by tbfpri and ignored +pointer sp, itp, otp, intable, outtable, index, colptr + +string nomatch "Number of input tables must match output tables" + +bool clgetb() +int fstati() +int tbnget(), tbnlen(), tbpsta() +pointer tbtopn(), tbnopenp(), tbnopen() + +begin + # Allocate stack memory for strings + + call smark (sp) + call salloc (intable, SZ_FNAME, TY_CHAR) + call salloc (outtable, SZ_FNAME, TY_CHAR) + call salloc (expr, SZ_LINE, TY_CHAR) + call salloc (columns, SZ_LINE, TY_CHAR) + call salloc (sort, SZ_LINE, TY_CHAR) + + # Read the task parameters + + if (fstati (STDIN, F_REDIR) == YES) + ilist = tbnopen ("STDIN") + else + ilist = tbnopenp ("intable") + + if (fstati (STDOUT, F_REDIR) == YES) + olist = tbnopen ("STDOUT") + else + olist = tbnopenp ("outtable") + + call clgstr ("expr", Memc[expr], SZ_LINE) + call clgstr ("columns", Memc[columns], SZ_LINE) + call clgstr ("sort", Memc[sort], SZ_LINE) + uniq = clgetb ("uniq") + ascend = clgetb ("ascend") + casesens = clgetb ("casesens") + + # Loop over all table names in the input file name template + + if (tbnlen (ilist) != tbnlen (olist)) + call error (SYNTAX, nomatch) + + while (tbnget (ilist, Memc[intable], SZ_FNAME) != EOF) { + + junk = tbnget (olist, Memc[outtable], SZ_FNAME) + + # Open the tables and set output table type + + itp = tbtopn (Memc[intable], READ_ONLY, NULL) + call tbfpri (Memc[intable], Memc[outtable], phu_copied) + otp = tbtopn (Memc[outtable], NEW_FILE, NULL) + + type = tbpsta (itp, TBL_WHTYPE) + call tbpset (otp, TBL_WHTYPE, type) + + # Create index arrays + + call allrows (itp, nindex, index) + call allcols (itp, numcol, colptr) + + # Do the query, returning an array of column pointers + # and row indices + + call doquery (itp, Memc[expr], Memc[columns], Memc[sort], + uniq, ascend, casesens, + numcol, Memi[colptr], nindex, Memi[index]) + + # Copy header and selected rows and columns to output table + + call wquery (itp, otp, numcol, Memi[colptr], nindex, Memi[index]) + + # Close the tables and free dynamic memory + + call tbtclo (itp) + call tbtclo (otp) + call mfree (colptr, TY_INT) + call mfree (index, TY_INT) + } + + # Close the filename template lists + + call tbnclose (ilist) + call tbnclose (olist) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tquery/wquery.x b/pkg/utilities/nttools/tquery/wquery.x new file mode 100644 index 00000000..33cc25ff --- /dev/null +++ b/pkg/utilities/nttools/tquery/wquery.x @@ -0,0 +1,50 @@ +include + +# WQUERY -- Copy selected columns and rows to output table +# +# B.Simon 19-Oct-87 First Code + +procedure wquery (itp, otp, numcol, colptr, nindex, index) + +pointer itp # i: Input table descriptor +pointer otp # i: Output table descriptor +int numcol # i: Number of column pointers +pointer colptr[ARB] # i: Array of column pointers +int nindex # i: Size of index array +int index[ARB] # i: Array of row indices +#-- +int iptr, idx, jdx +int colnum[1], datatype[1], lendata[1], lenfmt[1] +pointer sp, ocp, newcol, colname, colunits, colfmt + +begin + # Set up arrays in dynamic memory + + call smark (sp) + call salloc (newcol, numcol, TY_INT) + call salloc (colname, SZ_COLNAME, TY_CHAR) + call salloc (colunits, SZ_COLUNITS, TY_CHAR) + call salloc (colfmt, SZ_COLFMT, TY_CHAR) + + + # Copy column information from the input table to the output table + + do iptr = 1, numcol { + call tbcinf (colptr[iptr], colnum, Memc[colname], Memc[colunits], + Memc[colfmt], datatype[1], lendata[1], lenfmt[1]) + call tbcdef (otp, ocp, Memc[colname], Memc[colunits], Memc[colfmt], + datatype[1], lendata[1], 1) + Memi[newcol+iptr-1] = ocp + } + + # Copy the table columns a row at a time + + call tbtcre (otp) + call tbhcal (itp, otp) + do idx = 1, nindex { + jdx = index[idx] + call tbrcsc (itp, otp, colptr, Memi[newcol], jdx, idx, numcol) + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tread.par b/pkg/utilities/nttools/tread.par new file mode 100644 index 00000000..3a9a0000 --- /dev/null +++ b/pkg/utilities/nttools/tread.par @@ -0,0 +1,4 @@ +table,f,a,,,,Input table +columns,s,h," ",,,List of columns to edit +silent,b,h,no,,,Don't ring bell? +mode,s,h,al diff --git a/pkg/utilities/nttools/trebin.par b/pkg/utilities/nttools/trebin.par new file mode 100644 index 00000000..d2f08d2c --- /dev/null +++ b/pkg/utilities/nttools/trebin.par @@ -0,0 +1,14 @@ +intable,s,a,"",,,"input tables" +outtable,s,a,"",,,"output tables or directory" +column,s,a,"",,,"name of independent variable column" +start,r,a,,,,"first output value of independent variable" +end,r,a,,,,"last value of independent variable" +step,r,a,,,,"increment in independent variable" +xtable,s,h,"",,,"tables of indep var values for output" +function,s,h,"linear","nearest|linear|poly3|spline",,"interpolation function" +extrapolate,b,h,no,,,"extrapolate if out of bounds?" +value,r,h,INDEF,,,"value to use if out of bounds" +padvalue,r,h,INDEF,,,"value to ignore at end of indep var array" +verbose,b,h,yes,,,"print operations performed?" +Version,s,h,"4May2000",,,"date of installation" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/trebin/mkpkg b/pkg/utilities/nttools/trebin/mkpkg new file mode 100644 index 00000000..7b1e83c3 --- /dev/null +++ b/pkg/utilities/nttools/trebin/mkpkg @@ -0,0 +1,27 @@ +# Update the trebin application code in the ttools package library +# Author: Phil Hodge, 2-DEC-1988 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + tnamcls.x + tnamgio.x + tnaminit.x + trebin.x + tucspl.f + tudcol.x + tugcol.x + tugetput.x + tuhunt.f + tuiep3.f + tuifit.x trebin.h + tuinterp.x + tuiset.x trebin.h + tuispl.f + tuival.x trebin.h + tutrim.x + tuxget.x + ; diff --git a/pkg/utilities/nttools/trebin/tnamcls.x b/pkg/utilities/nttools/trebin/tnamcls.x new file mode 100644 index 00000000..80ded94f --- /dev/null +++ b/pkg/utilities/nttools/trebin/tnamcls.x @@ -0,0 +1,24 @@ +# tnam_cls -- close input & output fnt +# Close the file name templates. +# +# Phil Hodge, 15-Apr-1988 Subroutine created. +# Phil Hodge, 4-Oct-1995 Modify to use tbn instead of fnt. +# Phil Hodge, 25-Apr-2000 Add xin_t to calling sequence, and remove dir_only. + +procedure tnam_cls (in_t, xin_t, out_t) + +pointer in_t # io: fnt pointer for input tables +pointer xin_t # io: fnt pointer for tables of output indep var +pointer out_t # io: fnt pointer for output tables +#-- + +begin + if (in_t != NULL) + call tbnclose (in_t) + + if (xin_t != NULL) + call tbnclose (xin_t) + + if (out_t != NULL) + call tbnclose (out_t) +end diff --git a/pkg/utilities/nttools/trebin/tnamgio.x b/pkg/utilities/nttools/trebin/tnamgio.x new file mode 100644 index 00000000..a3d29af5 --- /dev/null +++ b/pkg/utilities/nttools/trebin/tnamgio.x @@ -0,0 +1,79 @@ +# tnam_gio -- get input & output names +# Get the next input and output table names. +# +# Phil Hodge, 15-Apr-1988 Task created. +# Phil Hodge, 4-Oct-1995 Modify to use tbn instead of fnt; use tbparse. +# Phil hodge, 16-Apr-1999 Remove ttype from calling sequence of tbparse. +# Phil Hodge, 25-Apr-2000 Add xin_t, xtable, maxch to calling sequence, +# and remove dir_only. + +int procedure tnam_gio (in_t, xin_t, out_t, outdir, + intable, xtable, outtable, maxch) + +pointer in_t # i: fnt pointer for input tables +pointer xin_t # i: fnt pointer for tables of output X +pointer out_t # i: fnt pointer for output tables +char outdir[ARB] # i: name of output directory +char intable[ARB] # o: name of next input table +char xtable[ARB] # o: name of next table for output X +char outtable[ARB] # o: name of next output table +int maxch # i: size of table name strings +#-- +pointer sp +pointer filename # name of table file, without brackets +pointer scratch +int nchar # value of tbnget for intable +int junk, hdu, tbparse() +int dir_len # length of root portion of table name +int tbnget(), tbnlen(), fnldir() +errchk tbparse + +begin + # Get the next input table name. + nchar = tbnget (in_t, intable, SZ_LINE) + if (nchar == EOF) + return (EOF) + + # Get the next table for output independent variable values. + if (xin_t != NULL) { + if (tbnlen (xin_t) == 1) # only one xtable? + call tbnrew (xin_t) + if (tbnget (xin_t, xtable, SZ_LINE) == EOF) + return (EOF) + } else { + xtable[1] = EOS + } + + if (out_t != NULL) { + + # Get the next output table name. + if (tbnget (out_t, outtable, SZ_LINE) == EOF) + return (EOF) + + } else { # output is a directory name + + call smark (sp) + call salloc (filename, SZ_LINE, TY_CHAR) + call salloc (scratch, SZ_LINE, TY_CHAR) + + # Copy the portion of the table name without brackets to + # Memc[filename]; we need to get rid of the brackets because + # they confuse fnldir. + junk = tbparse (intable, Memc[filename], Memc[scratch], + SZ_LINE, hdu) + + # Get the length of the directory prefix. + dir_len = fnldir (Memc[filename], Memc[scratch], SZ_LINE) + + # Copy the output directory name to outtable. + call strcpy (outdir, outtable, SZ_LINE) + + # Append the name of the input file (without directory prefix + # and without any bracket suffix) to the output directory. + call strcat (Memc[filename+dir_len], outtable, SZ_LINE) + + call sfree (sp) + } + + return (nchar) +end diff --git a/pkg/utilities/nttools/trebin/tnaminit.x b/pkg/utilities/nttools/trebin/tnaminit.x new file mode 100644 index 00000000..9e5ef686 --- /dev/null +++ b/pkg/utilities/nttools/trebin/tnaminit.x @@ -0,0 +1,75 @@ +include # to check whether input or output is redirected + +# tnam_init -- initialize for input & output names +# Get the input and output table name lists. If the output is just a +# directory name, the name will be copied to outdir; otherwise, the +# number of names in the input and output lists must be the same. +# +# Phil Hodge, 14-Apr-1988 Task created. +# Phil Hodge, 17-Jun-1993 Change YES to NO in calls to fntopnb. +# Phil Hodge, 4-Oct-1995 Modify to use tbn instead of fnt. +# Phil Hodge, 22-Apr-1999 Include explicit test for STDOUT, since +# isdirectory thinks STDOUT is a directory. +# Phil Hodge, 8-Jun-1999 Set input/output to STDIN/STDOUT if redirected. +# Phil Hodge, 25-Apr-2000 Get inlist, xlist, outlist in trebin, and add +# those three and xin_t to the calling sequence. + +procedure tnam_init (inlist, xlist, outlist, + in_t, xin_t, out_t, outdir, maxch) + +char inlist[ARB] # i: list of input table names +char xlist[ARB] # i: list of table names for output indep var +char outlist[ARB] # i: list of output table names +pointer in_t # o: fnt pointer for input tables +pointer xin_t # o: fnt pointer for tables of output X +pointer out_t # o: fnt pointer for output tables +char outdir[ARB] # o: if dir_only, name of output directory +int maxch # i: size of outdir string +#-- +int n_in, n_xin, n_out # number of tables in each list +bool dir_only # output just a directory name? +pointer tbnopen() +int isdirectory(), tbnlen() +bool strne() + +begin + dir_only = false + if (isdirectory (outlist, outdir, SZ_LINE) > 0 && + strne (outlist, "STDOUT")) + dir_only = true + + in_t = tbnopen (inlist) + xin_t = tbnopen (xlist) + + n_in = tbnlen (in_t) + n_xin = tbnlen (xin_t) + if (n_xin < 1) { + call tbnclose (xin_t) + xin_t = NULL + } + + if (dir_only) { + out_t = NULL + n_out = 0 + } else { + out_t = tbnopen (outlist) + n_out = tbnlen (out_t) + } + + if (xin_t != NULL) { + # It's OK to have just one xtable for all intables. + if (n_in != n_xin && n_xin != 1) { + call tnam_cls (in_t, xin_t, out_t) + call error (1, + "intable and xtable lists are not the same length") + } + } + + if (out_t != NULL) { + if (n_in != n_out) { + call tnam_cls (in_t, xin_t, out_t) + call error (1, + "intable and outtable lists are not the same length") + } + } +end diff --git a/pkg/utilities/nttools/trebin/trebin.h b/pkg/utilities/nttools/trebin/trebin.h new file mode 100644 index 00000000..0164ab3e --- /dev/null +++ b/pkg/utilities/nttools/trebin/trebin.h @@ -0,0 +1,5 @@ +# Codes for interpolating functions. +define I_NEAREST 1 # nearest neighbor +define I_LINEAR 2 # linear interpolation +define I_POLY3 3 # four-point polynomial interpolation +define I_SPLINE 4 # cubic spline interpolation diff --git a/pkg/utilities/nttools/trebin/trebin.x b/pkg/utilities/nttools/trebin/trebin.x new file mode 100644 index 00000000..873f3b05 --- /dev/null +++ b/pkg/utilities/nttools/trebin/trebin.x @@ -0,0 +1,136 @@ +include +include +include "trebin.h" + +# trebin -- resample to uniform spacing +# This task resamples a table or list of tables to uniformly spaced +# values of the independent variable. +# +# Phil Hodge, 14-Apr-1988 Task created. +# Phil Hodge, 30-Jan-1992 Delete inlist, outlist. +# Phil Hodge, 16-Jun-1993 Set the sign of 'step' based on 'start' and 'end'. +# Phil Hodge, 4-Oct-1995 Modify to use tbn instead of fnt. +# Phil Hodge, 21-May-1996 Include extrapolate and ext_value. +# Phil Hodge, 22-Apr-1999 Get 'step' even if 'start' and 'end' are the same. +# Phil Hodge, 25-Apr-2000 Get inlist, outlist, xlist in this routine +# instead of in tnam_init; also get padvalue. +# Phil Hodge, 4-Nov-2000 It is an error if step = 0, unless start = end + +procedure trebin() + +pointer sp +pointer inlist # scratch for list of input table names +pointer outlist # scratch for list of output table names +pointer xlist # scratch for list of table names for X +pointer intable # scratch for name of input table +pointer outtable # scratch for name of output table +pointer outdir # scratch for name of output directory +pointer xtable # scratch for name of indep var table +double iv_start # starting value of independent variable +double iv_end # ending value of independent variable +double iv_step # increment in independent variable +bool extrapolate # true means extrapolate if out of bounds +double ext_value # value to use when out of bounds +double padvalue # value at end of input indep. var. to ignore +char iv_col[SZ_COLNAME] # name of independent variable column +char func[SZ_FNAME] # interpolation function +int i_func # interpolation function +pointer in_t, xin_t, out_t # fn template pointers for input & output lists +bool verbose # print file names? +double clgetd() +bool clgetb() +int tnam_gio() + +begin + # Get input and output table template lists. + call smark (sp) + call salloc (inlist, SZ_LINE, TY_CHAR) + call salloc (outlist, SZ_LINE, TY_CHAR) + call salloc (xlist, SZ_LINE, TY_CHAR) + call salloc (intable, SZ_FNAME, TY_CHAR) + call salloc (outtable, SZ_FNAME, TY_CHAR) + call salloc (xtable, SZ_FNAME, TY_CHAR) + call salloc (outdir, SZ_FNAME, TY_CHAR) + + call clgstr ("intable", Memc[inlist], SZ_LINE) + call clgstr ("outtable", Memc[outlist], SZ_LINE) + call clgstr ("column", iv_col, SZ_COLNAME) + call clgstr ("xtable", Memc[xlist], SZ_LINE) + + # Open the input & output lists of table names. + call tnam_init (Memc[inlist], Memc[xlist], Memc[outlist], + in_t, xin_t, out_t, Memc[outdir], SZ_FNAME) + + if (xin_t == NULL) { + + # Get parameters for linearly spaced output independent variable. + iv_start = clgetd ("start") + iv_end = clgetd ("end") + iv_step = clgetd ("step") + if (iv_step == 0.d0 && iv_start != iv_end) + call error (1, "step = 0 is invalid") + + # Set the sign of 'step', rather than expecting the user + # to set it correctly. + if (iv_start < iv_end) + iv_step = abs (iv_step) + else if (iv_start > iv_end) + iv_step = -abs (iv_step) + + } else { + + iv_start = 0.d0 + iv_end = 0.d0 + iv_step = 0.d0 + } + + call clgstr ("function", func, SZ_FNAME) + extrapolate = clgetb ("extrapolate") + if (extrapolate) + ext_value = INDEFD # not used + else + ext_value = clgetd ("value") + + padvalue = clgetd ("padvalue") + + verbose = clgetb ("verbose") + + call tuiset (func, i_func) # set interpolator type + + # Process each table. + while (tnam_gio (in_t, xin_t, out_t, Memc[outdir], + Memc[intable], Memc[xtable], Memc[outtable], SZ_FNAME) != EOF) { + + if (verbose) { + if (Memc[xtable] != EOS) { + call printf ("%s, %s --> %s\n") + call pargstr (Memc[intable]) + call pargstr (Memc[xtable]) + call pargstr (Memc[outtable]) + } else { + call printf ("%s --> %s\n") + call pargstr (Memc[intable]) + call pargstr (Memc[outtable]) + } + call flush (STDOUT) + } + + iferr { + call tuinterp (Memc[intable], Memc[xtable], Memc[outtable], + i_func, iv_col, iv_start, iv_end, iv_step, + extrapolate, ext_value, padvalue, verbose) + } then { + call erract (EA_WARN) + if (verbose) { + call eprintf ("This table will be skipped.\n") + } else { + call eprintf ("Table %s will be skipped.\n") + call pargstr (Memc[intable]) + } + next + } + } + + call tnam_cls (in_t, xin_t, out_t) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/trebin/tucspl.f b/pkg/utilities/nttools/trebin/tucspl.f new file mode 100644 index 00000000..511211b8 --- /dev/null +++ b/pkg/utilities/nttools/trebin/tucspl.f @@ -0,0 +1,52 @@ + subroutine tucspl (xa, ya, n, work, y2) +C +C Compute the second derivative of YA at each point in the array. +C This is the initialization needed in preparation for interpolating +C using cubic splines by the subroutine TUISPL. Input and output +C are all double precision. +C +C This routine was copied with slight modifications from the SPLINE +C subroutine in Numerical Recipes by Press, Flannery, Teukolsky and +C Vetterling. +C +C N i: number of elements in each array +C XA i: array of independent-variable values +C YA i: array of dependent-variable values +C WORK io: scratch array used for work space +C Y2 o: second derivative of YA at each point +C +CH Phil Hodge, 14-Apr-1988 Subroutine copied from Numerical Recipes SPLINE. +C + integer n + double precision xa(n), ya(n), work(n), y2(n) +C-- + integer i + double precision p, sig + +C These values (and y2(n) = 0) are for a "natural" spline. + y2(1) = 0. + work(1) = 0. +C +C This is the decomposition loop of the tridiagonal algorithm. +C Y2 and WORK are used for temporary storage of the decomposed factors. +C + do 10 i = 2, n-1 + sig = (xa(i) - xa(i-1)) / (xa(i+1) - xa(i-1)) + p = sig * y2(i-1) + 2. + y2(i) = (sig - 1.) / p + work(i) = (6. * ((ya(i+1) - ya(i)) / (xa(i+1) - xa(i)) + + - (ya(i) - ya(i-1)) / (xa(i) - xa(i-1))) / + + (xa(i+1) - xa(i-1)) - sig * work(i-1)) / p + 10 continue + +C "natural" spline + y2(n) = 0. +C +C This is the backsubstitution loop of the tridiagonal algorithm. +C + do 20 i = n-1, 1, -1 + y2(i) = y2(i) * y2(i+1) + work(i) + 20 continue + + return + end diff --git a/pkg/utilities/nttools/trebin/tudcol.x b/pkg/utilities/nttools/trebin/tudcol.x new file mode 100644 index 00000000..8a6d1300 --- /dev/null +++ b/pkg/utilities/nttools/trebin/tudcol.x @@ -0,0 +1,140 @@ +include + +# tudcol -- get column pointers +# Get pointers to input and output dependent variable columns, define +# columns in output table. +# The arrays icp & ocp of column pointers are of the same length, +# which will be less than the total number of columns because they +# do not include the independent variable column. +# +# Columns of type text or boolean will not be copied to the output table. +# If the independent variable column contains arrays, scalar columns will +# be copied to output without interpolation; array columns must be the same +# length as the independent variable column. +# If the independent variable column contains scalars, array columns will +# not be copied to output. +# If verbose is true, a message will be printed regarding skipped columns. +# +# Phil Hodge, 26-Apr-2000 Subroutine created, based on previous tugcol. + +procedure tudcol (itp, otp, iv_colname, outrows, + iv_icp, iv_ocp, icp, ocp, ncols, array, verbose) + +pointer itp # i: pointer to input table descriptor +pointer otp # i: pointer to output table descriptor +char iv_colname[ARB] # i: name of indep var column +int outrows # i: array length for output array columns +pointer iv_icp # o: ptr to descr for input indep var column +pointer iv_ocp # o: ptr to descr for output indep var column +pointer icp[ARB] # o: ptr to column descr for input table +pointer ocp[ARB] # o: ptr to column descr for output table +int ncols # o: number of dependent variable columns +bool array # o: true if indep var column contains arrays +bool verbose # i: print info? +#-- +pointer sp +pointer why # note regarding why a column is skipped +bool skip_this # true if column will not be copied to output +pointer cp # a column pointer +char cname[SZ_COLNAME] # a column name +char cunits[SZ_COLUNITS] # units for a column +char cfmt[SZ_COLFMT] # print format for a column +int dtype # data type of a column +int xnelem # number of input elements for indep var column +int iv_nelem # number of output elements for indep var column +int nelem # number of elements +int lenfmt # length of print format +int incols # number of columns in input table +int k # loop index +int cnum # column number (ignored) +pointer tbcnum() +int tbpsta() + +begin + call smark (sp) + call salloc (why, SZ_FNAME, TY_CHAR) + + incols = tbpsta (itp, TBL_NCOLS) + + call tbcfnd1 (itp, iv_colname, iv_icp) + if (iv_icp == NULL) + call error (1, "independent variable column not found") + + # Get info about indep var column in input table. + call tbcinf (iv_icp, cnum, cname, cunits, cfmt, dtype, xnelem, lenfmt) + + # Note that this test is based on the independent variable column. + array = (xnelem > 1) + + # The indep var column in the output table may contain arrays; + # iv_nelem will be used in the loop below when defining the output + # column of independent variable values. + if (array) + iv_nelem = outrows + else + iv_nelem = 1 + + if (verbose && array) { + call printf ("note: array columns in each row will be rebinned\n") + call flush (STDOUT) + } + + # Define the columns in the output table. + ncols = 0 + do k = 1, incols { + + skip_this = false # initial value + cp = tbcnum (itp, k) + + call tbcinf (cp, cnum, cname, cunits, cfmt, dtype, nelem, lenfmt) + + # Indep var column. + if (cp == iv_icp) { + call tbcdef1 (otp, iv_ocp, cname, cunits, cfmt, dtype, iv_nelem) + next + } + + if (array) { + if (nelem > 1 && nelem != xnelem) { # not the same size + skip_this = true + call strcpy ("array size is not the same", + Memc[why], SZ_FNAME) + } + } else { + if (nelem > 1) { # skip array columns + skip_this = true + call strcpy ("column contains arrays", Memc[why], SZ_FNAME) + } + if (dtype <= 0 || dtype == TY_CHAR || dtype == TY_BOOL) { + skip_this = true + if (dtype == TY_BOOL) { + call strcpy ("data type is boolean", + Memc[why], SZ_FNAME) + } else { + call strcpy ("data type is text string", + Memc[why], SZ_FNAME) + } + } + } + + if (skip_this) { + if (verbose) { + call printf (" skipping column `%s' (%s)\n") + call pargstr (cname) + call pargstr (Memc[why]) + call flush (STDOUT) + } + next + } + + # Define output column; save pointers for input & output. + ncols = ncols + 1 + if (array && nelem > 1) + nelem = outrows + icp[ncols] = cp + call tbcdef1 (otp, ocp[ncols], + cname, cunits, cfmt, dtype, nelem) + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/trebin/tugcol.x b/pkg/utilities/nttools/trebin/tugcol.x new file mode 100644 index 00000000..6d9dd10d --- /dev/null +++ b/pkg/utilities/nttools/trebin/tugcol.x @@ -0,0 +1,87 @@ +include +include + +# tugcol -- get input X values +# Get input independent variable column and check it to make +# sure it is either monotonically increasing or decreasing. +# +# Phil Hodge, 18-Apr-1988 Subroutine created +# Phil Hodge, 30-Jan-1992 Check independent variables more carefully. +# Phil Hodge, 27-Apr-2000 Move most of this routine to tudcol; +# rewrite to allow either array or scalar column. + +procedure tugcol (itp, iv_icp, row, xin, xnelem, padvalue, array) + +pointer itp # i: pointer to input table descriptor +pointer iv_icp # i: ptr to descr for input indep var column +int row # i: row number, if input column contains arrays +double xin[ARB] # o: input independent variable values +int xnelem # o: actual number of elements in xin array +double padvalue # i: ignore this value at end of xin array +bool array # i: true if input column contains arrays +#-- +pointer sp +pointer temp # scratch for checking indep var for duplicates +int nelem # array size +int nvals # number of elements actually gotten +int nrows # number of rows in input table +int i # loop index +int op # index in temp +int tbcigi(), tbpsta(), tbagtd() +string NOT_MONOTONIC "input independent variable is not monotonic" + +begin + if (array) { + + nelem = tbcigi (iv_icp, TBL_COL_LENDATA) + nvals = tbagtd (itp, iv_icp, row, xin, 1, nelem) + if (nvals != nelem) { + call eprintf ( + "Not all input independent variable data were gotten from row %d\n") + call pargi (row) + call error (1, "") + } + xnelem = nvals + + } else { + + nrows = tbpsta (itp, TBL_NROWS) + do i = 1, nrows + call tbegtd (itp, iv_icp, i, xin[i]) + xnelem = nrows + } + + # Trim trailing INDEF and pad values by reducing xnelem. + call tu_trim (xin, xnelem, padvalue) + + call smark (sp) + call salloc (temp, xnelem, TY_DOUBLE) + + # Copy the independent variable data to scratch, skipping embedded + # INDEF values. + op = 0 + do i = 1, xnelem { + if (!IS_INDEFD(xin[i])) { + Memd[temp+op] = xin[i] # op is zero indexed at this point + op = op + 1 + } + } + + if (op > 1) { + # Check the independent variable values to make sure they're + # monotonically increasing or decreasing. + if (Memd[temp+1] > Memd[temp]) { # increasing + do i = 2, op { # one indexed + if (Memd[temp+i-1] <= Memd[temp+i-2]) + call error (1, NOT_MONOTONIC) + } + } else { # decreasing + do i = 2, op { + if (Memd[temp+i-1] >= Memd[temp+i-2]) + call error (1, NOT_MONOTONIC) + } + } + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/trebin/tugetput.x b/pkg/utilities/nttools/trebin/tugetput.x new file mode 100644 index 00000000..e1359929 --- /dev/null +++ b/pkg/utilities/nttools/trebin/tugetput.x @@ -0,0 +1,142 @@ +include + +# tu_getput -- do the interpolation +# This routine reads the independent and dependent variable values, +# does the interpolation, and writes the results to the output table. +# +# Phil Hodge, 24-April-2000 subroutine created + +procedure tu_getput (itp, otp, iv_icp, iv_ocp, + icp, ocp, ncols, + xout, outrows, iv_step, + i_func, extrapolate, ext_value, padvalue, array, verbose) + +pointer itp, otp # i: descr of input & output tables +pointer iv_icp # i: column descr for input indep var column +pointer iv_ocp # i: column descr for output indep var column +pointer icp[ncols] # i: column descriptors for input table +pointer ocp[ncols] # i: column descriptors for output table +int ncols # i: number of columns to copy +double xout[ARB] # i: output indep var values +int outrows # i: size of xout +double iv_step # i: increment in independent variable +int i_func # i: interpolation function code +bool extrapolate # i: true means don't use ext_value +double ext_value # i: value to assign to extrapolated points +double padvalue # i: value at end of input indep. var. to ignore +bool array # i: true if indep var column contains arrays +bool verbose # i: print info? +#-- +pointer sp +pointer xin # scratch for input indep var values +pointer yin # scratch for input data values +pointer y2 # scratch for second derivatives (spline only) +pointer xa # scratch for non-indef indep var values +pointer ya # scratch for non-indef dep var values +pointer yout # array of interpolated values +double dbuf # one interpolated value +int inrows # number of rows in input table +int xnelem # number of elements in xin, INDEF & padvalue trimmed +int nelem # allocated number of elements in array +int nvals # number of array elements actually gotten +int n # size of xa, ya, y2 (counting only non-INDEF values) +int row, col # loop indices +int i +int tbpsta(), tbcigi(), tbagtd() +errchk tugcol, tbagtd, tbaptd, tbegtd, tbeptd, tbrcsc + +begin + call smark (sp) + + inrows = tbpsta (itp, TBL_NROWS) + + if (array) + nelem = tbcigi (iv_icp, TBL_COL_LENDATA) + else + nelem = inrows + call salloc (xin, nelem, TY_DOUBLE) + call salloc (yin, nelem, TY_DOUBLE) + call salloc (y2, nelem, TY_DOUBLE) + call salloc (xa, nelem, TY_DOUBLE) + call salloc (ya, nelem, TY_DOUBLE) + + if (array) { + + call salloc (yout, outrows, TY_DOUBLE) + + # for each row in the input table ... + do row = 1, inrows { + + # Get input independent variable array from current row. + call tugcol (itp, iv_icp, row, Memd[xin], xnelem, + padvalue, array) + + # Put output indep var values into current row. + call tbaptd (otp, iv_ocp, row, xout, 1, outrows) + + # for each column to be interpolated ... + do col = 1, ncols { + nelem = tbcigi (icp[col], TBL_COL_LENDATA) + if (nelem == 1) { + # just copy scalar column + call tbrcsc (itp, otp, icp[col], ocp[col], row, row, 1) + } else { + nvals = tbagtd (itp, icp[col], row, Memd[yin], 1, nelem) + call tuifit (i_func, Memd[xin], Memd[yin], xnelem, + Memd[xa], Memd[ya], Memd[y2], n) + if (n > 0) { + do i = 1, outrows { + # interpolate + call tuival (i_func, + Memd[xa], Memd[ya], Memd[y2], n, + extrapolate, ext_value, xout, + i, outrows, iv_step, Memd[yout+i-1]) + } + # put the result + call tbaptd (otp, ocp[col], row, + Memd[yout], 1, outrows) + } else if (verbose && row == 1) { + call printf ("not enough data for interpolation\n") + call flush (STDOUT) + } + } + } + } + + } else { + + # Get input independent variable column. + row = 1 + call tugcol (itp, iv_icp, row, Memd[xin], xnelem, padvalue, array) + + # Put output independent variable values into output table column. + do row = 1, outrows + call tbeptd (otp, iv_ocp, row, xout[row]) + + # for each column to be interpolated ... + do col = 1, ncols { + + do row = 1, inrows + call tbegtd (itp, icp[col], row, Memd[yin+row-1]) + + # xnelem will be less than or equal to inrows. + call tuifit (i_func, Memd[xin], Memd[yin], xnelem, + Memd[xa], Memd[ya], Memd[y2], n) + + if (n > 0) { + do row = 1, outrows { + # interpolate, and put the result + call tuival (i_func, Memd[xa], Memd[ya], Memd[y2], n, + extrapolate, ext_value, + xout, row, outrows, iv_step, dbuf) + call tbeptd (otp, ocp[col], row, dbuf) + } + } else if (verbose) { + call printf ("not enough data for interpolation\n") + call flush (STDOUT) + } + } + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/trebin/tuhunt.f b/pkg/utilities/nttools/trebin/tuhunt.f new file mode 100644 index 00000000..3d8df648 --- /dev/null +++ b/pkg/utilities/nttools/trebin/tuhunt.f @@ -0,0 +1,103 @@ + subroutine tuhunt (xa, n, x, klo) +C +C The array XA is searched for an element KLO such that +C xa(klo) <= x <= xa(klo+1) +C If X < XA(1) then KLO is set to zero; if X > XA(N) then KLO is set to N. +C That is, KLO = 0 or N is a flag indicating X is out of bounds. +C +C KLO must be set to an initial guess on input; it will then be replaced +C by the correct value on output. +C +C This routine was copied with some modifications from the HUNT +C subroutine in Numerical Recipes by Press, Flannery, Teukolsky and +C Vetterling. +C +C N i: number of elements in each array +C XA i: array of independent-variable values +C X i: the value to be bracketed by elements in XA +C KLO io: the lower index in XA that brackets X +C +CH Phil Hodge, 14-Apr-1988 Subroutine copied from Numerical Recipes HUNT. +CH Phil Hodge, 21-May-1996 Don't flag endpoints of XA as out of bounds. +C + integer n, klo + double precision xa(n), x +C-- + integer inc, km, khi + logical ascnd + +C Set ASCND, and check for X out of bounds. + + if (xa(n).gt.xa(1)) then + ascnd = .true. + if (x .lt. xa(1)) then + klo = 0 + return + else if (x .gt. xa(n)) then + klo = n + return + end if + else + ascnd = .false. + if (x .gt. xa(1)) then + klo = 0 + return + else if (x .lt. xa(n)) then + klo = n + return + end if + end if + + if ((klo .le. 0) .or. (klo .gt. n)) then + klo = 1 + khi = n + go to 3 + endif + + inc = 1 + if ((x.ge.xa(klo) .and. ascnd) .or. + + (x.lt.xa(klo) .and. .not.ascnd)) then +1 khi = klo + inc + if (khi .gt. n) then + khi = n + 1 + else if ((x.ge.xa(khi) .and. ascnd) .or. + + (x.lt.xa(khi) .and. .not.ascnd)) then + klo = khi + inc = inc + inc + go to 1 + endif + else + khi = klo +2 klo = khi - inc + if (klo .lt. 1) then + klo = 0 + else if ((x.lt.xa(klo) .and. ascnd) .or. + + (x.ge.xa(klo) .and. .not.ascnd)) then + khi = klo + inc = inc + inc + go to 2 + endif + endif + +3 continue +C Before we return, make sure we don't return a value of KLO that +C implies X is out of bounds. We know it isn't because we checked +C at the beginning. + if (khi-klo .eq. 1) then + klo = max (klo, 1) + klo = min (klo, n-1) + return + end if + + km = (khi + klo) / 2 + + if ((x .gt. xa(km) .and. ascnd) .or. + + (x .le. xa(km) .and. .not.ascnd)) then + klo = km + else + khi = km + endif + + go to 3 + + end diff --git a/pkg/utilities/nttools/trebin/tuiep3.f b/pkg/utilities/nttools/trebin/tuiep3.f new file mode 100644 index 00000000..58f81a99 --- /dev/null +++ b/pkg/utilities/nttools/trebin/tuiep3.f @@ -0,0 +1,71 @@ + subroutine tuiep3 (xa, ya, x, y, dy) +C +C Evaluate a cubic polynomial interpolation function at X. +C xa(klo) <= x <= xa(klo+1) +C This routine was copied with slight modifications from the POLINT +C subroutine in Numerical Recipes by Press, Flannery, Teukolsky and +C Vetterling. +C +C XA i: array of four independent-variable values +C YA i: array of four dependent-variable values +C X i: the independent variable +C Y o: the result of interpolations +C DY o: an estimate of the error of interpolation +C +CH Phil Hodge, 18-Apr-1988 Subroutine copied from Numerical Recipes POLINT. +C + double precision xa(4), ya(4), x, y, dy +C-- + integer n +C four-point interpolation + parameter (n = 4) + + double precision c(n), d(n), dif, dift, den + double precision ho, hp, w + integer i, m, ns + + do 10 i = 1, n + if (x .eq. xa(i)) then + y = ya(i) + return + endif + 10 continue + + ns = 1 + dif = abs (x - xa(1)) + + do 20 i = 1, n + dift = abs (x - xa(i)) + if (dift .lt. dif) then + ns = i + dif = dift + endif + c(i) = ya(i) + d(i) = ya(i) + 20 continue + + y = ya(ns) + ns = ns - 1 + + do 40 m = 1, n-1 + + do 30 i = 1, n-m + ho = xa(i) - x + hp = xa(i+m) - x + w = c(i+1) - d(i) + den = w / (ho - hp) + d(i) = hp * den + c(i) = ho * den + 30 continue + + if (2*ns .lt. n-m) then + dy = c(ns+1) + else + dy = d(ns) + ns = ns - 1 + endif + y = y + dy + 40 continue + + return + end diff --git a/pkg/utilities/nttools/trebin/tuifit.x b/pkg/utilities/nttools/trebin/tuifit.x new file mode 100644 index 00000000..2f3a2d84 --- /dev/null +++ b/pkg/utilities/nttools/trebin/tuifit.x @@ -0,0 +1,63 @@ +include "trebin.h" + +# tuifit -- initialize or fit +# The input arrays of independent and dependent variable values are copied +# to output arrays, skipping indef values. The number of good values +# (i.e. not indef) is checked to make sure there are enough for the type +# of interpolation specified. In the case of spline interpolation, the +# array y2 of second derivatives is computed. +# +# Phil Hodge, 18-Apr-1988 Subroutine created +# Phil Hodge, 17-Jun-1993 Require at least two values for linear interpolation. + +procedure tuifit (i_func, xin, yin, inrows, + xa, ya, y2, n) + +int i_func # i: interpolation function code +double xin[ARB] # i: array of independent-variable values +double yin[ARB] # i: array of dependent-variable values +int inrows # i: size of xin, yin arrays +double xa[ARB] # o: array of independent-variable values +double ya[ARB] # o: array of dependent-variable values +double y2[ARB] # o: used only by spline interpolation +int n # o: size of xa, ya, y2 arrays +#-- +pointer sp +pointer work # scratch for spline fit +int k # loop index + +begin + n = 0 # initial value + + do k = 1, inrows { + if ( ! IS_INDEFD(xin[k]) && ! IS_INDEFD(yin[k])) { + n = n + 1 + xa[n] = xin[k] + ya[n] = yin[k] + } + } + + switch (i_func) { + case I_NEAREST: + if (n < 1) + n = 0 # flag it as bad + + case I_LINEAR: + if (n < 2) + n = 0 + + case I_POLY3: + if (n < 4) + n = 0 + + case I_SPLINE: + if (n >= 4) { + call smark (sp) + call salloc (work, n, TY_DOUBLE) + call tucspl (xa, ya, n, Memd[work], y2) + call sfree (sp) + } else { + n = 0 + } + } +end diff --git a/pkg/utilities/nttools/trebin/tuinterp.x b/pkg/utilities/nttools/trebin/tuinterp.x new file mode 100644 index 00000000..3a3b1d89 --- /dev/null +++ b/pkg/utilities/nttools/trebin/tuinterp.x @@ -0,0 +1,139 @@ +include +include +include "trebin.h" + +# tuinterp -- interpolate to regrid a table +# Open the input & output tables, interpolate to uniformly spaced values +# of the independent variable, and close the tables. +# +# Phil Hodge, 15-Apr-1988 Subroutine created +# Phil Hodge, 12-May-1989 Include check for not enough data to interpolate. +# Phil Hodge, 12-Jun-1989 Also copy header parameters. +# Phil Hodge, 30-Jan-1992 Call tbtclo instead of close. +# Phil Hodge, 16-Jun-1993 Check number of rows for interpolation function. +# Phil Hodge, 4-Apr-1994 Errchk tbtopn, and use iferr for tbtcre. +# Phil Hodge, 20-May-1996 Pass extrapolate and ext_value to tuival. +# Phil Hodge, 29-Jul-1998 Add iv_step to calling sequence of tuival. +# Phil Hodge, 8-Apr-1999 Call tbfpri. +# Phil Hodge, 22-Apr-1999 Don't set output table type if outtable = STDOUT. +# Phil Hodge, 25-Apr-2000 Add xtable, padvalue, verbose to calling sequence. +# Phil Hodge, 30-Oct-2001 Delete just the output table, not the whole file, +# if there's an error. +# Phil Hodge, 2-Jan-2002 Remove the statements to delete the output table +# in case the input table is not monotonic (because +# calling tbtclo for a text table caused the error +# message to be replaced by a misleading message). + +procedure tuinterp (intable, xtable, outtable, + i_func, iv_colname, iv_start, iv_end, iv_step, + extrapolate, ext_value, padvalue, verbose) + +char intable[ARB] # i: name of input table +char xtable[ARB] # i: table of output indep var values +char outtable[ARB] # i: name of output table +int i_func # i: interpolation function code +char iv_colname[SZ_COLNAME] # i: name of independent variable column +double iv_start # i: starting value of independent variable +double iv_end # i: ending value of independent variable +double iv_step # i: increment in independent variable +bool extrapolate # i: true means don't use ext_value +double ext_value # i: value to assign to extrapolated points +double padvalue # i: value at end of input indep. var. to ignore +bool verbose # i: print info? +#-- +pointer sp +pointer itp, otp # descr of input & output tables +pointer iv_icp # descr for input indep var column +pointer iv_ocp # descr for output indep var column +pointer icpp, ocpp # column descr for i & o tables +pointer xout # scratch for output indep var values +int ttype # indicates row- or column-ordered +int ncols # number of dependent variable columns +int incols # total number of input columns +int outrows # number of rows in output table +int phu_copied # set by tbfpri and ignored +bool array # true if indep var column contains arrays +pointer tbtopn() +int tbpsta() +bool strne() +errchk tbfpri, tbtopn, tbtdel, tudcol, tuxget, tu_getput + +begin + call smark (sp) + + itp = tbtopn (intable, READ_ONLY, 0) + incols = tbpsta (itp, TBL_NCOLS) + + # Either read or compute the values of the independent variable + # at which we will interpolate the values from the input table. + iferr { + call tuxget (xtable, iv_start, iv_end, iv_step, padvalue, + xout, outrows) + } then { + call tbtclo (itp) + call erract (EA_ERROR) + } + + iferr { + call tbfpri (intable, outtable, phu_copied) + otp = tbtopn (outtable, NEW_FILE, NULL) + } then { + call mfree (xout, TY_DOUBLE) + call tbtclo (itp) + call erract (EA_ERROR) + } + + call salloc (icpp, incols, TY_POINTER) + call salloc (ocpp, incols, TY_POINTER) + + # Define output columns, and get column pointers. + iferr { + call tudcol (itp, otp, iv_colname, outrows, + iv_icp, iv_ocp, Memi[icpp], Memi[ocpp], ncols, array, verbose) + } then { + call mfree (xout, TY_DOUBLE) + call tbtclo (itp) + call tbtclo (otp) + call erract (EA_ERROR) + } + + # Output table should be same type as input table. + if (strne (outtable, "STDOUT")) { + ttype = tbpsta (itp, TBL_WHTYPE) + call tbpset (otp, TBL_WHTYPE, ttype) + if (ttype == TBL_TYPE_S_COL) { + call tbpset (otp, TBL_ALLROWS, + max (outrows, tbpsta (itp, TBL_ALLROWS))) + } + } + + iferr { + call tbtcre (otp) # create output table + } then { + call mfree (xout, TY_DOUBLE) + call tbtclo (itp) + call tbtclo (otp) + call erract (EA_ERROR) + } + + call tbhcal (itp, otp) # copy all header parameters + + # For each column, get the data, do the interpolation, + # write the results. + iferr { + call tu_getput (itp, otp, iv_icp, iv_ocp, + Memi[icpp], Memi[ocpp], ncols, + Memd[xout], outrows, iv_step, + i_func, extrapolate, ext_value, padvalue, array, verbose) + } then { + call mfree (xout, TY_DOUBLE) + call tbtclo (itp) + call erract (EA_ERROR) + } + + call mfree (xout, TY_DOUBLE) + call sfree (sp) + + call tbtclo (itp) + call tbtclo (otp) +end diff --git a/pkg/utilities/nttools/trebin/tuiset.x b/pkg/utilities/nttools/trebin/tuiset.x new file mode 100644 index 00000000..427df021 --- /dev/null +++ b/pkg/utilities/nttools/trebin/tuiset.x @@ -0,0 +1,26 @@ +include "trebin.h" + +# tuiset -- set interpolation type +# +# +# P.E. Hodge, 18-Apr-88 Subroutine created + +procedure tuiset (func, i_func) + +char func[ARB] # i: interpolation function +int i_func # o: interpolation function code +#-- +int strncmp() + +begin + if (func[1] == 'n') + i_func = I_NEAREST + else if (func[1] == 'l') + i_func = I_LINEAR + else if (strncmp (func, "poly3", 5) == 0) + i_func = I_POLY3 + else if (func[1] == 's') + i_func = I_SPLINE + else + call error (1, "unknown interpolation function") +end diff --git a/pkg/utilities/nttools/trebin/tuispl.f b/pkg/utilities/nttools/trebin/tuispl.f new file mode 100644 index 00000000..2f4c68b8 --- /dev/null +++ b/pkg/utilities/nttools/trebin/tuispl.f @@ -0,0 +1,32 @@ + subroutine tuispl (xa, ya, y2, x, y) +C +C Interpolate at point X using cubic splines. The array Y2 must have +C previously been computed by calling TUCSPL. Note that XA, YA, Y2 +C are two-element subarrays of the arrays with the same names elsewhere. +C Input and output are all double precision. +C This routine was copied with slight modifications from the SPLINT +C subroutine in Numerical Recipes by Press, Flannery, Teukolsky and +C Vetterling. +C +C XA i: pair of independent-variable values +C YA i: pair of dependent-variable values +C Y2 i: second derivatives of YA at each point +C X i: value at which spline is to be computed +C Y o: interpolated value at X +C +CH Phil Hodge, 14-Apr-1988 Subroutine copied from Numerical Recipes SPLINT. +C + double precision xa(2), ya(2), y2(2), x, y +C-- + double precision h, a, b + + h = xa(2) - xa(1) + + a = (xa(2) - x) / h + b = (x - xa(1)) / h + y = a * ya(1) + b * ya(2) + + + ((a**3 - a) * y2(1) + (b**3 - b) * y2(2)) + + * h * h / 6. + + return + end diff --git a/pkg/utilities/nttools/trebin/tuival.x b/pkg/utilities/nttools/trebin/tuival.x new file mode 100644 index 00000000..20354a5d --- /dev/null +++ b/pkg/utilities/nttools/trebin/tuival.x @@ -0,0 +1,272 @@ +include "trebin.h" + +# tuival -- interpolate +# Interpolate to get one value. +# A zero value of iv_step means that the output independent-variable values +# may not be uniformly spaced, so the interval x1,x2 must be gotten from +# the xout array. (This is relevant for linear interpolation only.) +# +# Phil Hodge, 18-Apr-1988 Subroutine created +# Phil Hodge, 20-May-1996 Include extrapolate and ext_value for extrapolation. +# Phil Hodge, 29-Jul-1998 For 1-D, fit a line instead of interpolating, +# add iv_step to calling sequence, add subroutines +# tu_range and tu_fit1. +# Phil Hodge, 22-Apr-1999 The test on whether x is outside the range of +# the data did not consider that xa could be decreasing. +# Phil Hodge, 25-Apr-2000 Change calling sequence: x --> xout, j, outrows; +# this is to support the option of a nonuniformly spaced output +# independent variable array. + +procedure tuival (i_func, xa, ya, y2, n, + extrapolate, ext_value, xout, j, outrows, iv_step, y) + +int i_func # i: interpolation function code +double xa[n] # i: input independent-variable values +double ya[n] # i: input dependent-variable values +double y2[n] # i: used only by spline interpolation +int n # i: size of xa, ya, y2 arrays +bool extrapolate # i: extrapolate rather than use ext_value? +double ext_value # i: value to assign if x is out of bounds +double xout[ARB] # i: output independent variable array +int j # i: current element of xout +int outrows # i: size of xout array +double iv_step # i: spacing of x values (can be negative) +double y # o: the interpolated value +#-- +double x # independent variable +double x1, x2 # beginning and end of output pixel +double dy # an estimate of the error of interpolation +int klo, khi # indexes within xa that bracket x +int npts # number of points in interval + +begin + x = xout[j] + + # Initial guess for klo; we want xa[klo] <= x <= xa[klo+1]. + klo = (n + 1) / 2 + khi = klo + + # If x falls outside the range of the data, either extrapolate + # (below) or assign a fixed value ext_value. + if (!extrapolate && n > 1) { + if (xa[1] < xa[2] && (x < xa[1] || x > xa[n])) { # increasing + y = ext_value + return + } + if (xa[1] > xa[2] && (x > xa[1] || x < xa[n])) { # decreasing + y = ext_value + return + } + } + + switch (i_func) { + case I_NEAREST: + + # Find klo such that xa[klo] <= x <= xa[klo+1], starting from + # current klo. + call tuhunt (xa, n, x, klo) + klo = max (klo, 1) + klo = min (klo, n) + khi = min (klo+1, n) + if (abs (x - xa[klo]) < abs (x - xa[khi])) + y = ya[klo] + else + y = ya[khi] + + case I_LINEAR: + + # Get x1 and x2. + call tu_x1x2 (xout, j, outrows, iv_step, x1, x2) + + # Get klo, khi, and npts. + call tu_range (xa, ya, n, x1, x2, klo, khi, npts) + if (npts > 1) { + # Fit a line to the data from klo to khi inclusive. + call tu_fit1 (xa, ya, x, klo, khi, y) + } else { + # Interpolate. + klo = klo - 1 + call tuhunt (xa, n, x, klo) + klo = max (klo, 1) + klo = min (klo, n-1) + call tuiep1 (xa[klo], ya[klo], x, y) + } + + case I_POLY3: + + call tuhunt (xa, n, x, klo) + klo = max (klo, 2) + klo = min (klo, n-2) + # Pass tuiep3 the four points at klo-1, klo, klo+1, klo+2. + call tuiep3 (xa[klo-1], ya[klo-1], x, y, dy) + + case I_SPLINE: + + call tuhunt (xa, n, x, klo) + klo = max (klo, 1) + klo = min (klo, n-1) + call tuispl (xa[klo], ya[klo], y2[klo], x, y) + } +end + +# This routine gets the endpoints x1,x2 of the current output pixel. +# If the output independent variable array is uniformly spaced, x1 and x2 +# will just be the current pixel xout[j] - or + iv_step/2. If the output +# independent variable array is (or may be) nonuniformly spaced, indicated +# by iv_step being zero, then x1 and x2 will be the midpoints of intervals +# adjacent to xout[j] on the left and right. +# +# x1 may be less than, equal to, or greater than x2. + +procedure tu_x1x2 (xout, j, outrows, iv_step, x1, x2) + +double xout[ARB] # i: output independent variable array +int j # i: current element of xout +int outrows # i: size of xout array +double iv_step # i: spacing of x values (can be negative) +double x1, x2 # o: endpoints of output pixel + +begin + if (iv_step != 0) { + # output is uniformly spaced + x1 = xout[j] - iv_step / 2.d0 + x2 = xout[j] + iv_step / 2.d0 + } else { + if (outrows == 1) { + x1 = xout[1] + x2 = xout[1] + } else if (j == 1) { + x2 = (xout[1] + xout[2]) / 2.d0 + x1 = xout[1] - (x2 - xout[1]) + } else if (j == outrows) { + x1 = (xout[outrows-1] + xout[outrows]) / 2.d0 + x2 = xout[outrows] + (xout[outrows] - x1) + } else { + x1 = (xout[j-1] + xout[j]) / 2.d0 + x2 = (xout[j] + xout[j+1]) / 2.d0 + } + } +end + +# tu_range -- find range of indexes +# This routine finds the range of indexes in xa and ya corresponding to +# the interval x1 to x2. The range is klo to khi; klo will be less than +# or equal to khi, even though xa can be either increasing or decreasing. +# klo and khi will also be within the range 1 to n inclusive, even if +# x1 to x2 is outside the range xa[1] to xa[n]. npts will be set to +# the actual number of elements of xa within the interval x1 to x2; +# thus, npts can be zero. +# +# x1 and x2 will be interchanged, if necessary, so that the array index +# in xa corresponding to x1 will be smaller than the array index corresponding +# to x2, i.e. so klo will be smaller than khi. +# +# Note that klo is used as an initial value when hunting for a value in xa, +# so klo must have been initialized to a reasonable value before calling +# this routine. + +procedure tu_range (xa, ya, n, x1, x2, klo, khi, npts) + +double xa[n] # i: array of independent-variable values +double ya[n] # i: array of dependent-variable values +int n # i: size of xa, ya, y2 arrays +double x1, x2 # io: endpoints of output pixel +int klo, khi # io: range of indices in xa within x1,x2 +int npts # o: number of elements in xa within x1,x2 +#-- +double temp # for swapping x1 and x2, if appropriate +int k1, k2 + +begin + # Swap x1 and x2 if necessary, so that klo will be less than or + # equal to khi. + if (xa[1] <= xa[2]) { # input X is increasing + if (x1 > x2) { + temp = x1; x1 = x2; x2 = temp + } + } else { # input X is decreasing + if (x1 < x2) { + temp = x1; x1 = x2; x2 = temp + } + } + + k1 = klo + call tuhunt (xa, n, x1, k1) + k1 = k1 + 1 # next point + klo = k1 + klo = min (klo, n) + + k2 = k1 + call tuhunt (xa, n, x2, k2) + khi = max (k2, 1) + khi = min (khi, n) + + # npts can be different from khi - klo + 1, and it can be zero. + npts = k2 - k1 + 1 +end + +# tu_fit1 -- fit a line (1-D) to data +# This routine fits a straight line to (xa[k],ya[k]) for k = klo to khi +# inclusive. The fit is then evaluated at x, and the result is returned +# as y. There must be at least two points, i.e. khi > klo. + +procedure tu_fit1 (xa, ya, x, klo, khi, y) + +double xa[ARB] # i: array of independent-variable values +double ya[ARB] # i: array of dependent-variable values +double x # i: independent variable +int klo, khi # i: range of indices in xa covered by iv_step +double y # o: value of fit at x +#-- +double sumx, sumy, sumxy, sumx2 +double xmean, ymean +double slope, intercept +int k + +begin + sumx = 0.d0 + sumy = 0.d0 + do k = klo, khi { + sumx = sumx + xa[k] + sumy = sumy + ya[k] + } + xmean = sumx / (khi - klo + 1) + ymean = sumy / (khi - klo + 1) + + sumxy = 0.d0 + sumx2 = 0.d0 + do k = klo, khi { + sumxy = sumxy + (xa[k] - xmean) * (ya[k] - ymean) + sumx2 = sumx2 + (xa[k] - xmean)**2 + } + slope = sumxy / sumx2 + intercept = (ymean - slope * xmean) + + y = intercept + slope * x +end + + +# tuiep1 -- linear interpolation +# Interpolate to get one value. X is supposed to be between xa[1] and +# xa[2], but it is not an error if x is outside that interval. Note +# that xa, ya are subarrays of the arrays with the same names elsewhere. + +procedure tuiep1 (xa, ya, x, y) + +double xa[2] # i: pair of independent-variable values +double ya[2] # i: pair of dependent-variable values +double x # i: independent variable +double y # o: the interpolated value +#-- +double p # fraction of distance between indep var val + +begin + if (x == xa[1]) { + y = ya[1] + } else if (x == xa[2]) { + y = ya[2] + } else { + p = (x - xa[1]) / (xa[2] - xa[1]) + y = p * ya[2] + (1.-p) * ya[1] + } +end diff --git a/pkg/utilities/nttools/trebin/tutrim.x b/pkg/utilities/nttools/trebin/tutrim.x new file mode 100644 index 00000000..e792c37a --- /dev/null +++ b/pkg/utilities/nttools/trebin/tutrim.x @@ -0,0 +1,43 @@ +# This routine trims elements from the end of the xout array by +# decrementing nelem. Values are trimmed if they are INDEF or +# equal to padvalue (and padvalue itself is not INDEF). Trimming +# starts at the end and stops with the first value that is not +# INDEF and not equal to padvalue. +# +# Phil Hodge, 26-Apr-2000 + +procedure tu_trim (xout, nelem, padvalue) + +double xout[ARB] # i: independent variable values +int nelem # io: size of xout array +double padvalue # i: trim these values at end of xout array +#-- +int curr_nelem # current value of nelem +int i + +begin + curr_nelem = nelem + + if (!IS_INDEFD(padvalue)) { + + # Check for either INDEF or padvalue. + do i = curr_nelem, 1, -1 { + if (IS_INDEFD(xout[i])) + nelem = nelem - 1 + else if (xout[i] == padvalue) + nelem = nelem - 1 + else # neither INDEF nor a pad value + break + } + + } else { + + # Just check for INDEF. + do i = curr_nelem, 1, -1 { + if (IS_INDEFD(xout[i])) + nelem = nelem - 1 + else # not INDEF + break + } + } +end diff --git a/pkg/utilities/nttools/trebin/tuxget.x b/pkg/utilities/nttools/trebin/tuxget.x new file mode 100644 index 00000000..9b890bb4 --- /dev/null +++ b/pkg/utilities/nttools/trebin/tuxget.x @@ -0,0 +1,134 @@ +include + +# The values of the independent variable for the output table can be +# read either from an input table (xtable), or they can be assigned +# from the start, increment, and end values. +# +# Phil Hodge, 25-Apr-2000 Subroutine created. +# Phil Hodge, 12-May-2004 errchk the procedures that are called. + +procedure tuxget (xtable, iv_start, iv_end, iv_step, padvalue, + xout, outrows) + +char xtable[ARB] # i: table of output indep var values +double iv_start # i: starting value of independent variable +double iv_end # i: ending value of independent variable +double iv_step # i: increment in independent variable +double padvalue # i: value at end of indep var array to ignore +pointer xout # o: pointer to output indep var values +int outrows # o: number of output rows (size of xout) +#-- +pointer tp, cp +int row, nrows +int i +int nelem # array size, or number of table rows +int nvals # number of elements read from column if it's an array +double dbuf +double direction # indicates increasing or decreasing data +double previous # for comparing current and previous values +pointer tbtopn(), tbcnum() +int tbpsta(), tbcigi(), tbagtd() +errchk tbtopn, tbpsta, tbcnum, tbcigi, tbtclo, tbagtd, tbegtd, tu_trim + +begin + if (xtable[1] != EOS) { + + tp = tbtopn (xtable, READ_ONLY, NULL) + if (tbpsta (tp, TBL_NCOLS) < 1) { + call tbtclo (tp) + call error (1, "No data in xtable") + } + if (tbpsta (tp, TBL_NCOLS) > 1) { + call tbtclo (tp) + call eprintf ("xtable %s contains more than one column;\n") + call pargstr (xtable) + call eprintf ( + "use a column selector [c:] to specify which column.\n") + call error (1, "") + } + + nrows = tbpsta (tp, TBL_NROWS) + cp = tbcnum (tp, 1) + nelem = tbcigi (cp, TBL_COL_LENDATA) + + if (nelem > 1 && nrows > 1) { + call tbtclo (tp) + call eprintf ("xtable %s contains more than one row,\n") + call pargstr (xtable) + call eprintf ("and the column contains arrays;\n") + call eprintf ( + "use a row selector [c:row=] to specify which row.\n") + call error (1, "") + } + + if (nelem == 1) + nelem = nrows + call malloc (xout, nelem, TY_DOUBLE) + + # Read the data from the table. + if (nrows == 1) { + row = 1 + nvals = tbagtd (tp, cp, row, Memd[xout], 1, nelem) + if (nvals < nelem) { + call tbtclo (tp) + call error (1, "not all elements read from xtable") + } + } else { + do row = 1, nrows + call tbegtd (tp, cp, row, Memd[xout+row-1]) + } + + call tbtclo (tp) + + # Trim trailing garbage by decrementing outrows. + outrows = nelem + call tu_trim (Memd[xout], outrows, padvalue) + + # Check for embedded INDEF values, and make sure the values + # are monotonically increasing or decreasing. + if (outrows > 1) { + + do i = 1, outrows { + if (IS_INDEFD(Memd[xout+i-1])) { + call eprintf ( + "xtable %s contains embedded INDEF values\n") + call pargstr (xtable) + call eprintf ("(i.e. not just trailing INDEFs)\n") + call error (1, "") + } + } + + if (Memd[xout+1] >= Memd[xout]) + direction = 1.d0 + else + direction = -1.d0 + previous = Memd[xout] - direction + do i = 1, outrows { + if (direction * (Memd[xout+i-1] - previous) <= 0.d0) { + call eprintf ( + "Values in xtable %s are not monotonic\n") + call pargstr (xtable) + call error (1, "") + } + previous = Memd[xout+i-1] + } + } + + } else { # no xtable + + # Find out how many rows the output table should have. + if (iv_start == iv_end) + outrows = 1 + else + outrows = nint ((iv_end - iv_start) / iv_step + 1.0) + + call malloc (xout, outrows, TY_DOUBLE) + + # Compute the independent variable values for the output table. + dbuf = iv_start + do i = 1, outrows { + Memd[xout+i-1] = dbuf + dbuf = dbuf + iv_step + } + } +end diff --git a/pkg/utilities/nttools/tselect.par b/pkg/utilities/nttools/tselect.par new file mode 100644 index 00000000..a4e9368f --- /dev/null +++ b/pkg/utilities/nttools/tselect.par @@ -0,0 +1,4 @@ +intable,s,a,,,,"Input tables" +outtable,s,a,,,,"Output tables" +expr,s,a,,,,"Expression used for selection" +mode,s,h,"a",,, diff --git a/pkg/utilities/nttools/tselect/mkpkg b/pkg/utilities/nttools/tselect/mkpkg new file mode 100644 index 00000000..69d01d6c --- /dev/null +++ b/pkg/utilities/nttools/tselect/mkpkg @@ -0,0 +1,12 @@ +# Update the tselect application code in the ttools package library +# Author: B.Simon, 25-NOV-1987 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + subset.x + tselect.x + ; diff --git a/pkg/utilities/nttools/tselect/subset.x b/pkg/utilities/nttools/tselect/subset.x new file mode 100644 index 00000000..06f574a3 --- /dev/null +++ b/pkg/utilities/nttools/tselect/subset.x @@ -0,0 +1,83 @@ +include +define SYNTAX 1 + +# SUBSET -- Select subset of table rows +# +# This procedure evaluates a boolean expession for selected rows in a table. +# If the expression is true, it is written to the output table +# +# B.Simon 7-Oct-87 First Code +# B.Simon 16-Dec-87 Changed to handle table subsets +# B.Simon 06-Jan-93 Changed to use ftnexpr +# B.Simon 25-Aug-98 Changed to write directly to output table + +procedure subset (itp, otp, expr) + +pointer itp # i: Input table descriptor +pointer otp # o: Output table descriptor +char expr[ARB] # i: Algebraic expression used in subset +#-- +char nl +pointer sp, newexp, ch +int fd, sd, ic, irow, orow, first, last + +int open(), stropen(), stridx(), tbpsta(), tbl_search() + +data nl / '\n' / +string badtype "Expression is not valid" + +errchk open, stropen, tbl_search + +begin + # Allocate dynamic memory for strings + + call smark (sp) + call salloc (newexp, SZ_COMMAND, TY_CHAR) + + # Check to see if the expression is a file name + + if (expr[1] != '@') { + # Copy the expression into string + + call strcpy (expr, Memc[newexp], SZ_COMMAND) + + } else { + # Copy the file into a string + + fd = open (expr[2], READ_ONLY, TEXT_FILE) + sd = stropen (Memc[newexp], SZ_COMMAND, WRITE_ONLY) + call fcopyo (fd, sd) + call close (fd) + call strclose (sd) + + # Replace the newlines with blanks + + ch = newexp + repeat { + ic = stridx (nl, Memc[ch]) + if (ic == 0) + break + ch = ch + ic + Memc[ch-1] = ' ' + } + } + + orow = 1 + first = 1 + last = tbpsta (itp, TBL_NROWS) + + while (first <= last) { + irow = tbl_search (itp, Memc[newexp], first, last) + if (irow < 1) + break + + call tbrcpy (itp, otp, irow, orow) + first = irow + 1 + orow = orow + 1 + } + + if (irow == ERR) + call error (SYNTAX, badtype) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tselect/tselect.x b/pkg/utilities/nttools/tselect/tselect.x new file mode 100644 index 00000000..266753c5 --- /dev/null +++ b/pkg/utilities/nttools/tselect/tselect.x @@ -0,0 +1,83 @@ +include # to check whether I/O is redirected + +define SYNTAX 1 + +# TSELECT -- Create a new table from selected rows of an old table +# +# B.Simon 7-Oct-1987 First Code +# Phil Hodge 7-Sep-1988 Change parameter names for tables. +# Phil Hodge 4-Oct-1995 Use table name template routines tbnopenp, etc. +# B.Simon 25-Aug-1998 Changed to write directly to output table +# Phil Hodge 8-Apr-1999 Call tbfpri. +# Phil Hodge 9-Jun-1999 Set input/output to STDIN/STDOUT if redirected. + +procedure t_tselect() + +pointer ilist # Input table name template +pointer olist # Output table name template +pointer expr # Expression used to select rows +#-- +int junk +int phu_copied # set by tbfpri and ignored +pointer sp, itp, otp, intable, outtable + +string nomatch "Number of input tables must match output tables" + +int fstati() +int tbnget(), tbnlen() +pointer tbtopn(), tbnopenp(), tbnopen() + +begin + # Allocate stack memory for strings + + call smark (sp) + call salloc (intable, SZ_FNAME, TY_CHAR) + call salloc (outtable, SZ_FNAME, TY_CHAR) + call salloc (expr, SZ_LINE, TY_CHAR) + + # Read the task parameters + + if (fstati (STDIN, F_REDIR) == YES) + ilist = tbnopen ("STDIN") + else + ilist = tbnopenp ("intable") + + if (fstati (STDOUT, F_REDIR) == YES) + olist = tbnopen ("STDOUT") + else + olist = tbnopenp ("outtable") + + call clgstr ("expr", Memc[expr], SZ_LINE) + + # Loop over all table names in the input file name template + + if (tbnlen (ilist) != tbnlen (olist)) + call error (SYNTAX, nomatch) + + while (tbnget (ilist, Memc[intable], SZ_FNAME) != EOF) { + junk = tbnget (olist, Memc[outtable], SZ_FNAME) + + # Open the tables + + itp = tbtopn (Memc[intable], READ_ONLY, NULL) + call tbfpri (Memc[intable], Memc[outtable], phu_copied) + otp = tbtopn (Memc[outtable], NEW_COPY, itp) + + # Copy header and selected rows to output table + + call tbtcre (otp) + call tbhcal (itp, otp) + call subset (itp, otp, Memc[expr]) + + # Close the tables + + call tbtclo (itp) + call tbtclo (otp) + } + + # Close the filename template lists + + call tbnclose (ilist) + call tbnclose (olist) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tsort.par b/pkg/utilities/nttools/tsort.par new file mode 100644 index 00000000..b1656bba --- /dev/null +++ b/pkg/utilities/nttools/tsort.par @@ -0,0 +1,5 @@ +table,s,a,,,,"Tables to sort" +columns,s,a,,,,"Columns to sort on" +ascend,b,h,yes,,,"Ascending order?" +casesens,b,h,yes,,,"Case sensitive sort?" +mode,s,h,"a",,, diff --git a/pkg/utilities/nttools/tsort/mkpkg b/pkg/utilities/nttools/tsort/mkpkg new file mode 100644 index 00000000..7e918942 --- /dev/null +++ b/pkg/utilities/nttools/tsort/mkpkg @@ -0,0 +1,14 @@ +# Update the tsort application code in the ttools package library +# Author: B.Simon, 25-NOV-1987 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + tblextsort.x + tblintsort.x + tblmaxrow.x + tsort.x + ; diff --git a/pkg/utilities/nttools/tsort/tblextsort.x b/pkg/utilities/nttools/tsort/tblextsort.x new file mode 100644 index 00000000..48981179 --- /dev/null +++ b/pkg/utilities/nttools/tsort/tblextsort.x @@ -0,0 +1,496 @@ +include + +define MERGEORDER 15 + +# TBL_EXTSORT -- External table sort based on Software Tools +# +# B.Simon 21-Feb-91 First Code +# B.Simon 15-Mar-00 Modified to speed up code +# Phil Hodge 10-Sep-04 Add new procedure tut_replace, and call it +# instead of tbtdel/tbtren; use tbrcsc instead +# of tbrcpy in tut_cpytab. +# Phil Hodge 15-Sep-04 Make 'heap' an array of one, because it is +# declared to be an array in tut_deltab. +# Copy the original table one set of rows at a +# time to an "srt_cpy" temp table, and generate +# the sorted index array from that; this is to +# work around a file I/O buffer problem when +# sorting an STSDAS-format table. +# Phil Hodge 6-Oct-05 Find column pointers in heap table, instead +# of using colptr. +# Remove tp from calling sequence of tut_opntab. + +procedure tbl_extsort (tp, numptr, colptr, maxrow, casesens, ascend) + +pointer tp # u: Table descriptor +int numptr # i: Number of columns to sort on (size of colptr) +pointer colptr[ARB] # i: Array of column descriptors +int maxrow # i: Maximum number of rows to sort at one time +bool casesens # i: Sort is case sensitive +bool ascend # i: Sort in ascending order +#-- +bool fold +int irow, mrow, nrow, ntab +int low, high, limit +pointer sp, index, tmproot, tmpname, tabname +pointer otp, heap[1], itp[MERGEORDER] +# These are for a copy of a portion of the original table. +pointer cpyname, tp_cpy[1] +pointer cp_cpy # column descriptors in srt_cpy temporary table +pointer cp_heap # column descriptors in heap temporary table + +pointer tbtopn(), tut_maktab() +int tbpsta() + +begin + # Allocate dynamic memory for temporary strings + + call smark (sp) + call salloc (tmproot, SZ_FNAME, TY_CHAR) + call salloc (tmpname, SZ_FNAME, TY_CHAR) + call salloc (tabname, SZ_FNAME, TY_CHAR) + call salloc (cpyname, SZ_FNAME, TY_CHAR) # the srt_cpy table + + call salloc (cp_cpy, numptr, TY_POINTER) + call salloc (cp_heap, numptr, TY_POINTER) + + # Initialize variables for external sort + + high = 0 + fold = ! casesens + call malloc (index, maxrow, TY_INT) + + # This root name is used only for the srt_cpy temporary table. + # Create the srt_cpy temporary table, and find the pointers to + # column descriptors corresponding to colptr. + call mktemp ("tmp$srt_cpy", Memc[tmproot], SZ_FNAME) + tp_cpy[1] = tut_maktab (Memc[tmproot], 0, tp) + call tut_fndcol (colptr, tp_cpy, Memi[cp_cpy], numptr) + + # This rootname is used for all the other temporary tables. + call mktemp ("tmp$srt", Memc[tmproot], SZ_FNAME) + + # Extract one buffer's worth of rows from original table to the + # srt_cpy temporary table, generate a sorted index array, and + # copy/sort to another temporary table. + + nrow = tbpsta (tp, TBL_NROWS) + for (irow = 1; irow <= nrow; irow = irow + maxrow) { + + mrow = min (maxrow, nrow-irow+1) + + # Extract rows to the srt_cpy table, without changing the order. + call tut_setidx (irow, mrow, Memi[index]) + call tut_cpytab (tp, tp_cpy[1], true, mrow, Memi[index]) + call tbtflu (tp_cpy[1]) # flush so we can read the table + + # Generate the index array for the srt_cpy table. + call tut_setidx (1, mrow, Memi[index]) + call tbtsrt (tp_cpy[1], numptr, Memi[cp_cpy], + fold, mrow, Memi[index]) + + # Copy (in sorted order) the srt_cpy table to a temporary table. + high = high + 1 + otp = tut_maktab (Memc[tmproot], high, tp) + call tut_cpytab (tp_cpy[1], otp, ascend, mrow, Memi[index]) + call tbtclo (otp) + } + call tut_deltab (tp_cpy, 1) # done with the srt_cpy table + + # Merge the temporary tables into a single sorted table + + heap[1] = tut_maktab (Memc[tmproot], 0, tp) + call tut_fndcol (colptr, heap[1], Memi[cp_heap], numptr) + + for (low = 1; low < high; low = low + MERGEORDER) { + limit = min (low+MERGEORDER-1, high) + ntab = limit - low + 1 + + call tut_opntab (Memc[tmproot], low, limit, itp) + high = high + 1 + + otp = tut_maktab (Memc[tmproot], high, tp) + call tut_mrgtab (itp, ntab, numptr, + fold, ascend, heap[1], Memi[cp_heap], otp) + + call tut_deltab (itp, ntab) + # We really only need the name of the last table created. + call tbtnam (otp, Memc[tmpname], SZ_FNAME) + call tbtclo (otp) + } + call tut_deltab (heap, 1) + + call tbtnam (tp, Memc[tabname], SZ_FNAME) + + # Copy sorted temporary table to original table, and delete + # temporary table + otp = tbtopn (Memc[tmpname], READ_ONLY, NULL) + call tut_replace (otp, tp) + call tbtclo (tp) + call tbtclo (otp) + call tbtdel (Memc[tmpname]) + + # Free dynamic memory + + call mfree (index, TY_INT) + call sfree (sp) +end + + +#-----------------------------------------------------------------------# +# # +# These procedures are utility routines used by tbl_extsort() # +# They should not be called by other routines # +# # +#-----------------------------------------------------------------------# + +# TUT_FNDCOL -- Get pointers to column descriptors + +# Get the pointers to column descriptors for the srt_cpy temporary table. +# Use the column name rather than number for the original table to allow +# for the possibility that the column numbers are not the same in both +# tables, e.g. if a column selector was used with the original table name. + +procedure tut_fndcol (colptr, tp_cpy, cp_cpy, numptr) + +pointer colptr[ARB] # i: Array of column descriptors in original table +pointer tp_cpy # i: Descriptor for the srt_cpy temporary table +pointer cp_cpy[ARB] # o: Array of column descriptors in tp_cpy table +int numptr # i: Number of columns in colptr and cp_cpy arrays +#-- +char colname[SZ_COLNAME] +int colnum + +begin + do colnum = 1, numptr { + call tbcigt (colptr[colnum], TBL_COL_NAME, colname, SZ_COLNAME) + call tbcfnd1 (tp_cpy, colname, cp_cpy[colnum]) + } +end + +# TUT_CPYTAB -- Copy sorted rows to temporary table + +procedure tut_cpytab (tp, otp, ascend, nrow, index) + +pointer tp # i: Input table descriptor +pointer otp # i: Output table descriptor +bool ascend # i: Write output in ascending sort order? +int nrow # i: Number of rows to write +int index[ARB] # i: Array of row indices +#-- +char colname[SZ_COLNAME] +pointer cp, ocp +int ncols, colnum +int irow +pointer tbcnum() +int tbpsta() + +begin + # Number of columns in temporary table + ncols = tbpsta (otp, TBL_NCOLS) + call malloc (cp, ncols, TY_POINTER) + call malloc (ocp, ncols, TY_POINTER) + + # Get pointers to column descriptors + do colnum = 1, ncols { + Memi[ocp+colnum-1] = tbcnum (otp, colnum) + call tbcigt (Memi[ocp+colnum-1], TBL_COL_NAME, colname, SZ_COLNAME) + call tbcfnd1 (tp, colname, Memi[cp+colnum-1]) + } + + if (ascend) { + do irow = 1, nrow { + call tbrcsc (tp, otp, Memi[cp], Memi[ocp], + index[irow], irow, ncols) + } + } else { + do irow = nrow, 1, -1 { + call tbrcsc (tp, otp, Memi[cp], Memi[ocp], + index[irow], nrow-irow+1, ncols) + } + } + + call mfree (cp, TY_POINTER) + call mfree (ocp, TY_POINTER) +end + +# TUT_REPLACE -- Copy sorted rows to temporary table +# This copies each row to the original table, without first deleting +# the original table. + +procedure tut_replace (otp, tp_orig) + +pointer otp # i: Descriptor for sorted temporary table +pointer tp_orig # i: Descriptor for original table +#-- +pointer sp +pointer ocp, cp_orig +char colname[SZ_COLNAME] +int nrows, ncols +int row, colnum +pointer tbcnum() +int tbpsta() + +begin + call smark (sp) + + ncols = tbpsta (otp, TBL_NCOLS) + call salloc (ocp, ncols, TY_POINTER) + call salloc (cp_orig, ncols, TY_POINTER) + + # Get the pointers to column descriptors for the sorted and original + # tables. + do colnum = 1, ncols { + Memi[ocp+colnum-1] = tbcnum (otp, colnum) + call tbcigt (Memi[ocp+colnum-1], TBL_COL_NAME, colname, SZ_COLNAME) + call tbcfnd1 (tp_orig, colname, Memi[cp_orig+colnum-1]) + } + + nrows = tbpsta (otp, TBL_NROWS) + do row = 1, nrows { + call tbrcsc (otp, tp_orig, Memi[ocp], Memi[cp_orig], + row, row, ncols) + } + + call sfree (sp) +end + +# TUT_DELTAB -- Delete a group of temporary tables + +procedure tut_deltab (itp, ntab) + +pointer itp[ARB] # i: Array of table descriptors +int ntab # i: Number of tables to delete +#-- +int itab +pointer sp, tmpname + +begin + call smark (sp) + call salloc (tmpname, SZ_FNAME, TY_CHAR) + + do itab = 1, ntab { + call tbtnam (itp[itab], Memc[tmpname], SZ_FNAME) + call tbtclo (itp[itab]) + call tbtdel (Memc[tmpname]) + } + + call sfree (sp) +end + +# TUT_MAKNAM -- Construct a table name by appending a suffix to the root + +procedure tut_maknam (tmproot, index, tmpname, maxch) + +char tmproot[ARB] # i: Table name root +int index # i: Number to use as suffix +char tmpname[ARB] # o: Full table name +int maxch # i: Declared length of table name +#-- +int ic + +int gstrcpy(), itoc() + +begin + ic = gstrcpy (tmproot, tmpname, maxch) + 1 + ic = itoc (index, tmpname[ic], maxch-ic) + ic + ic = gstrcpy (".tab", tmpname[ic], maxch-ic) +ic + tmpname[ic] = EOS +end + +# TUT_MAKTAB -- Create a table for temporary storage + +pointer procedure tut_maktab (tmproot, index, tp) + +char tmproot[ARB] # i: Table name root +int index # i: Number to use as suffix +pointer tp # i: Table to use as template +#-- +pointer sp, otp, tmpname + +pointer tbtopn() + +begin + call smark (sp) + call salloc (tmpname, SZ_FNAME, TY_CHAR) + + call tut_maknam (tmproot, index, Memc[tmpname], SZ_FNAME) + + iferr { + otp = tbtopn (Memc[tmpname], NEW_COPY, tp) + call tbpset (otp, TBL_WHTYPE, TBL_TYPE_S_ROW) + call tbtcre (otp) + call tbpset (otp, TBL_ADVICE, SEQUENTIAL) + } then { + call error (1, "Can't create temporary table used for sorting") + } + + call sfree (sp) + return (otp) +end + +# TUT_MRGTAB -- Merge a set of tables into a single table + +procedure tut_mrgtab (itp, ntab, numptr, fold, ascend, heap, cp, otp) + +pointer itp[ARB] # i: Array of input table descriptors +int ntab # i: Number of input tables +int numptr # i: Number of columns to merge on +bool fold # i: Fold case when merging? +bool ascend # i: Merge in ascending order? +pointer heap # i: Heap array descriptor +pointer cp[ARB] # i: Array of column descriptors in heap table +pointer otp # i: Output table descriptor +#-- +int nindex, itab, idx, jdx, temp +int irow[MERGEORDER], nrow[MERGEORDER], index[MERGEORDER] + +int tbpsta() + +begin + # Create heap by copying one row from each table + + nindex = 0 + do itab = 1, ntab { + irow[itab] = 1 + nrow[itab] = tbpsta (itp[itab], TBL_NROWS) + + if (nrow[itab] > 0) { + call tbrcpy (itp[itab], heap, 1, itab) + nindex = nindex + 1 + index[nindex] = itab + } + } + + # Put the heap in sort order + + call tbtsrt (heap, numptr, cp, fold, nindex, index) + if (!ascend) { + idx = 1 + jdx = nindex + while (idx < jdx) { + temp = index[idx] + index[idx] = index[jdx] + index[jdx] = temp + idx = idx + 1 + jdx = jdx - 1 + } + } + + # Copy a row from the heap, replacing it by a new row + + for (idx = 1; nindex > 0; idx = idx + 1) { + itab = index[1] + call tbrcpy (heap, otp, itab, idx) + + if (irow[itab] < nrow[itab]) { + irow[itab] = irow[itab] + 1 + call tbrcpy (itp[itab], heap, irow[itab], itab) + } else { + index[1] = index[nindex] + nindex = nindex - 1 + } + + call tut_reheap (heap, numptr, cp, fold, ascend, + nindex, index) + } +end + +# TUT_OPNTAB -- Open a group of temporary tables + +procedure tut_opntab (tmproot, low, limit, itp) + +char tmproot[ARB] # i: Temporary file name root +int low # i: First table to open +int limit # i: Last table to open +pointer itp[ARB] # o: Array of table descriptors +#-- +int itab +pointer sp, tmpname + +int tbtopn() + +begin + call smark (sp) + call salloc (tmpname, SZ_FNAME, TY_CHAR) + + do itab = 1, limit-low+1 { + call tut_maknam (tmproot, low+itab-1, Memc[tmpname], SZ_FNAME) + iferr (itp[itab] = tbtopn (Memc[tmpname], READ_ONLY, NULL)) + call error (1, "Can't open temporary table used for sorting") + } + + call sfree (sp) +end + +# TUT_REHEAP -- Restore heap to sort order + +procedure tut_reheap (heap, numptr, cp, fold, ascend, nindex, index) + +pointer heap # i: Heap table descriptor +int numptr # i: Number of columns to sort on +pointer cp[ARB] # i: Array of column descriptors in heap table +bool fold # i: Fold case together? +bool ascend # i: Put head in ascending order? +int nindex # i: Number of elements in index array +int index[ARB] # io: Array of head table indices in sort order +#-- +int order, irow, jrow, temp + +int tbrcmp() + +begin + # Set the sort order + + if (ascend) + order = 1 + else + order = -1 + + # A heap is organized as a binary tree. The heap is partially + # sorted so that a parent is in sort order with respect to its + # children. However, siblings are not necessarily in sort order. + # The children of index[irow] are at index[2*irow] and + # index[2*irow+1]. + + for (irow = 1; 2*irow <= nindex; irow = jrow) { + + # Find the smaller (larger) of the two children + + jrow = 2 * irow + if (jrow < nindex) { + if (tbrcmp (heap, numptr, cp, fold, + index[jrow], index[jrow+1]) == order) + jrow = jrow + 1 + } + + # If child is smaller (larger) than parent, + # exhange their indices + + if (tbrcmp (heap, numptr, cp, fold, + index[irow], index[jrow]) != order) { + break + + } else { + temp = index[irow] + index[irow] = index[jrow] + index[jrow] = temp + } + } + +end + +# TUT_SETIDX -- Set up the index array + +procedure tut_setidx (irow, nrow, index) + +int irow # i: starting value +int nrow # i: number of rows in index array +int index[ARB] # o: index array +#-- +int jrow + +begin + do jrow = 1, nrow + index[jrow] = irow + jrow - 1 +end diff --git a/pkg/utilities/nttools/tsort/tblintsort.x b/pkg/utilities/nttools/tsort/tblintsort.x new file mode 100644 index 00000000..100f17c1 --- /dev/null +++ b/pkg/utilities/nttools/tsort/tblintsort.x @@ -0,0 +1,48 @@ +# TBL_INTSORT -- Internal table sort for small tables +# +# B.Simon 21-Feb-91 First Code +# B.Simon 30-Jan-96 Close table in this routine + +procedure tbl_intsort (tp, numptr, colptr, casesens, ascend) + +pointer tp # u: Table descriptor +int numptr # i: Number of columns to sort on +pointer colptr[ARB] # i: Array of column descriptors +bool casesens # i: Sort is case sensitive +bool ascend # i: Sort in ascending order +#-- +bool fold +int nindex, idx, jdx, temp +pointer index + +begin + # Call the sort routine in the table library + + fold = ! casesens + call allrows (tp, nindex, index) + call tbtsrt (tp, numptr, colptr, fold, nindex, Memi[index]) + + # Reorder the index array if ascend is false + + if (! ascend) { + idx = 1 + jdx = nindex + while (idx < jdx) { + temp = Memi[index+idx-1] + Memi[index+idx-1] = Memi[index+jdx-1] + Memi[index+jdx-1] = temp + idx = idx + 1 + jdx = jdx - 1 + } + } + + # Reorder the table according to the values in the index array + + call reorder (tp, nindex, Memi[index]) + + # Close the table and free dynamic memory + + call tbtclo (tp) + call mfree (index, TY_INT) + +end diff --git a/pkg/utilities/nttools/tsort/tblmaxrow.x b/pkg/utilities/nttools/tsort/tblmaxrow.x new file mode 100644 index 00000000..28206ff6 --- /dev/null +++ b/pkg/utilities/nttools/tsort/tblmaxrow.x @@ -0,0 +1,39 @@ +include + +# TBL_MAXROW -- Compute the number of rows that fit in a buffer +# +# B.Simon 06-Mar-91 First Code +# B.Simon 15-Mar-00 Revised calculation of maxrow +# B.Simon 24-May-00 Temporary patch to avoid fits problem +# B.Simon 26-May-00 Restored old version after fix to fits problem +# Phil Hodge 10-Sep-04 Set lower limit of 5 on maxrow, because it +# could be unreasonably small (even zero, due +# to truncation). +# Phil Hodge 15-Sep-04 Reduce buffer size (maxsize) for STSDAS-format +# table, because actual buffer size appears to +# be smaller than the value returned by tbpsta(). + +int procedure tbl_maxrow (tp) + +pointer tp # i: table pointer +#-- +int tabtype, maxsize, maxrow +int tbpsta() + +begin + tabtype = tbpsta (tp, TBL_WHTYPE) + + if (tabtype == TBL_TYPE_S_COL || tabtype == TBL_TYPE_TEXT) { + + maxrow = tbpsta (tp, TBL_NROWS) + + } else { + maxsize = tbpsta (tp, TBL_BUFSIZE) + if (tabtype == TBL_TYPE_S_ROW) + maxsize = maxsize / 2 + maxrow = maxsize / tbpsta (tp, TBL_ROWLEN_CHAR) + maxrow = max (maxrow, 5) + } + + return (maxrow) +end diff --git a/pkg/utilities/nttools/tsort/tsort.x b/pkg/utilities/nttools/tsort/tsort.x new file mode 100644 index 00000000..81851631 --- /dev/null +++ b/pkg/utilities/nttools/tsort/tsort.x @@ -0,0 +1,98 @@ +include +define SYNTAX 1 + +# TSORT -- Sort a table on several columns at once +# +# This task sorts an SDAS format table. The column or columns to sort on are +# given by the parameter columns, which is a list of column names or column +# name patterns separated by commas. The most significant column name is the +# first in the list, subsequent columns are used to break ties. There are two +# flags, ascend and casesens. If ascend is true, the first row in the output +# table holds the smallest value if the sorted column is numeric or the first +# string in alpahabetic order if the sorted column is a character string. If +# casesens is true, upper case characters precede lower case charaters in sort +# order. Otherwise, case is not significant in determining the sort order. +# +# B.Simon 25-Sep-87 First Code +# B.Simon 15-Jul-88 Set buffer size to max +# Phil Hodge 7-Sep-88 Change parameter name for table. +# Phil Hodge 14-Nov-88 Set advice to sequential instead of +# setting buffer size. +# B.Simon 05-Feb-90 Use new internal sort routine +# B.Simon 21-Feb-91 Use external sort routine +# Phil Hodge 4-Oct-95 Use table name template routines tbnopenp, etc. + +procedure t_tsort() + +pointer table # Names of the tables to be sorted +pointer columns # Column name template +int maxrow # Maximum number of rows to sort internally +bool ascend # Ascending sort flag +bool casesens # Case sensitivity flag +#-- +int numcol, nrow, numptr +pointer sp, tp, colptr, list + +bool clgetb() +int tbnget() +pointer tbnopenp() +int tbpsta() +int tbl_maxrow() +pointer tbtopn() + +begin + # Allocate stack memory for strings + + call smark (sp) + call salloc (table, SZ_FNAME, TY_CHAR) + call salloc (columns, SZ_LINE, TY_CHAR) + + # Read the task parameters + + list = tbnopenp ("table") + call clgstr ("columns", Memc[columns], SZ_LINE) + ascend = clgetb ("ascend") + casesens = clgetb ("casesens") + + # Loop over all table names in the file name template + + while (tbnget (list, Memc[table], SZ_FNAME) != EOF) { + + # Open the table + + tp = tbtopn (Memc[table], READ_WRITE, NULL) + + # Set buffer size to a larger value. + + call tbpset (tp, TBL_ADVICE, SEQUENTIAL) + + # Create an array of column pointers from the column template + + numcol = tbpsta (tp, TBL_NCOLS) + nrow = tbpsta (tp, TBL_NROWS) + + call malloc (colptr, numcol, TY_INT) + call tctexp (tp, Memc[columns], numcol, numptr, Memi[colptr]) + + if (numptr == 0) + call error (SYNTAX, "Column(s) not found in table") + + # Choose between the internal and external sort routines + # Table is closed by sort routine + + maxrow = tbl_maxrow (tp) + if (nrow <= maxrow) + call tbl_intsort (tp, numptr, Memi[colptr], casesens, ascend) + else + call tbl_extsort (tp, numptr, Memi[colptr], maxrow, + casesens, ascend) + + call mfree (colptr, TY_INT) + + } + + # Close the filename template list + + call tbnclose (list) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tstat.par b/pkg/utilities/nttools/tstat.par new file mode 100644 index 00000000..ad947bda --- /dev/null +++ b/pkg/utilities/nttools/tstat.par @@ -0,0 +1,21 @@ +intable,s,a,"",,,"input tables" +column,s,a,"",,,"column in input tables" +outtable,s,h,"STDOUT",,,"output table or STDOUT" +lowlim,r,h,INDEF,,,"values below this are ignored" +highlim,r,h,INDEF,,,"values above this are ignored" +rows,s,h,"-",,,"range of rows to use for statistics" +n_tab,s,h,"table",,,"column name for name of input table" +n_nam,s,h,"column",,,"column name for name of input column" +n_nrows,s,h,"nrows",,,"column name for number of good rows" +n_mean,s,h,"mean",,,"column name for mean" +n_stddev,s,h,"stddev",,,"column name for standard deviation" +n_median,s,h,"median",,,"column name for median" +n_min,s,h,"min",,,"column name for minimum" +n_max,s,h,"max",,,"column name for maximum" +nrows,i,h,,,,"number of rows" +mean,r,h,,,,"mean value" +stddev,r,h,,,,"standard deviation" +median,r,h,,,,"median value" +vmin,r,h,,,,"minimum" +vmax,r,h,,,,"maximum" +mode,s,h,"al" diff --git a/pkg/utilities/nttools/tstat/mkpkg b/pkg/utilities/nttools/tstat/mkpkg new file mode 100644 index 00000000..f708c769 --- /dev/null +++ b/pkg/utilities/nttools/tstat/mkpkg @@ -0,0 +1,13 @@ +# Update the thistogram application code in the ttools package library +# Author: Phil Hodge, 2-DEC-1988 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + thistogram.x "thistogram.h" + thoptions.x "thistogram.h" + tstat.x + ; diff --git a/pkg/utilities/nttools/tstat/thistogram.h b/pkg/utilities/nttools/tstat/thistogram.h new file mode 100644 index 00000000..5c2c0910 --- /dev/null +++ b/pkg/utilities/nttools/tstat/thistogram.h @@ -0,0 +1,8 @@ +# thistogram.h +define NPAR 6 # there are six parameters altogether +define NBINS 1 # got[NBINS] = true means we have a value for nbins +define VLOW 2 +define VHIGH 3 +define DX 4 +define CLOW 5 +define CHIGH 6 diff --git a/pkg/utilities/nttools/tstat/thistogram.x b/pkg/utilities/nttools/tstat/thistogram.x new file mode 100644 index 00000000..7470e1a5 --- /dev/null +++ b/pkg/utilities/nttools/tstat/thistogram.x @@ -0,0 +1,348 @@ +include # defines EA_WARN +include # to check whether input or output is redirected +include +include "thistogram.h" # defines NPAR, etc. + +define MAX_RANGES (SZ_LINE/2) # max number of ranges of row numbers + +# thistogram -- make a histogram of a table column +# +# Phil Hodge, 2-Dec-1988 Task created. +# Phil Hodge, 12-Jan-1989 th_mk_hist: ignore values that are out of range +# Phil Hodge, 17-Mar-1994 Include parameters dx, clow, chigh. +# Phil Hodge, 3-Oct-1995 Modify to use tbn instead of fnt. +# Phil Hodge, 8-Apr-1999 Call tbfpri. +# Phil Hodge, 8-Jun-1999 Set input/output to STDIN/STDOUT if redirected. + +procedure thistogram() + +pointer inlist, outlist # scr for input & output lists of names +char colname[SZ_COLNAME] # column name +int t_nbins # number of bins +double t_vlow, t_vhigh # lower & upper limits for histogram +double t_dx # bin width +double t_clow, t_chigh # centers of first and last bins +char outcolx[SZ_COLNAME] # column name for indep var for histogram +char outcoly[SZ_COLNAME] # column name for dependent var for histogram +#-- +pointer sp +pointer itp, otp # ptr to table descriptor +pointer cptr # ptr to column descriptor +pointer ocpx, ocpy # ptr to col descr for output columns +pointer intab, outtab # scr for names of input & output tables +pointer range_string # string which gives ranges of row numbers +pointer val, counts # scr for histogram: indep & dep var + +# These six parameters are copied from t_... in each loop. +int nbins +double vlow, vhigh, dx, clow, chigh + +pointer list1, list2 +int i, junk +int nrows # number of rows included and not INDEF +int phu_copied # set by tbfpri and ignored +bool listout # is the output ASCII rather than a table? +bool got[NPAR] # flags to specify what we have got +bool find_datamin # true if we need to find minimum data value +bool find_datamax # true if we need to find maximum data value +pointer tbtopn() +double clgetd() +int fstati() +pointer tbnopen() +int clgeti(), tbnget(), tbnlen() +bool streq() + +begin + # Allocate scratch for lists of names and for table names. + call smark (sp) + call salloc (inlist, SZ_FNAME, TY_CHAR) + call salloc (outlist, SZ_FNAME, TY_CHAR) + call salloc (intab, SZ_FNAME, TY_CHAR) + call salloc (outtab, SZ_FNAME, TY_CHAR) + call salloc (range_string, SZ_FNAME, TY_CHAR) + + # Get task parameters. + + if (fstati (STDIN, F_REDIR) == YES) + call strcpy ("STDIN", Memc[inlist], SZ_FNAME) + else + call clgstr ("intable", Memc[inlist], SZ_FNAME) + + if (fstati (STDOUT, F_REDIR) == YES) + call strcpy ("STDOUT", Memc[outlist], SZ_FNAME) + else + call clgstr ("outtable", Memc[outlist], SZ_FNAME) + + call clgstr ("column", colname, SZ_COLNAME) + + # Some of these six parameters may be INDEF. The "t_" prefix + # means these are task parameters; they are assigned to variables + # (same name but without the "t_") in the loop over tables, and + # those variables may be modified within the loop. + t_nbins = clgeti ("nbins") + t_vlow = clgetd ("lowval") + t_vhigh = clgetd ("highval") + t_dx = clgetd ("dx") + t_clow = clgetd ("clow") + t_chigh = clgetd ("chigh") + + call clgstr ("rows", Memc[range_string], SZ_FNAME) + + listout = streq (Memc[outlist], "STDOUT") # ASCII output? + if ( ! listout ) { + call clgstr ("outcolx", outcolx, SZ_COLNAME) + call clgstr ("outcoly", outcoly, SZ_COLNAME) + } + + if (!IS_INDEF(t_dx)) + if (t_dx <= 0.d0) + call error (1, "dx must not be less than or equal to zero") + + # These parameters are interdependent, so compute what was not + # specified from those that were, as far as we can. + call th_options (t_nbins, t_vlow, t_vhigh, t_dx, t_clow, t_chigh, + got, find_datamin, find_datamax) + + # Expand the input table list. + list1 = tbnopen (Memc[inlist]) + + if ( ! listout ) { + # Expand the output table list. + list2 = tbnopen (Memc[outlist]) + if (tbnlen (list1) != tbnlen (list2)) { + call tbnclose (list1) + call tbnclose (list2) + call error (1, + "Number of input and output tables not the same") + } + } + + # Do for each input table. + while (tbnget (list1, Memc[intab], SZ_FNAME) != EOF) { + + # These may be modified within this loop by th_limits. + nbins = t_nbins + vlow = t_vlow + vhigh = t_vhigh + dx = t_dx + clow = t_clow + chigh = t_chigh + + itp = tbtopn (Memc[intab], READ_ONLY, NULL) + call tbcfnd (itp, colname, cptr, 1) + if (cptr == NULL) { + call tbtclo (itp) + call eprintf ("column not found in %s\n") + call pargstr (Memc[intab]) + if ( ! listout ) # skip next output table + junk = tbnget (list2, Memc[outtab], SZ_FNAME) + next + } + + # Get lower & upper limits for the histogram. + iferr { + call th_limits (itp, cptr, Memc[range_string], + nbins, vlow, vhigh, dx, clow, chigh, + got, find_datamin, find_datamax) + } then { + call erract (EA_WARN) + call eprintf ("Table `%s' will be skipped.\n") + call pargstr (Memc[intab]) + call tbtclo (itp) + next + } + + # Get scratch space for the histogram. + call malloc (val, nbins, TY_DOUBLE) + call malloc (counts, nbins, TY_INT) + + # Make the histogram. + call th_mk_hist (itp, cptr, nbins, vlow, vhigh, dx, + Memc[range_string], Memd[val], Memi[counts], nrows) + + if ( listout ) { + call printf ("# %d rows %s\n") + call pargi (nrows) + call pargstr (Memc[intab]) + do i = 1, nbins { + call printf ("%15.7g %8d\n") + call pargd (Memd[val+i-1]) + call pargi (Memi[counts+i-1]) + } + } else { + + # Create output table & define columns. + junk = tbnget (list2, Memc[outtab], SZ_FNAME) + call tbfpri (Memc[intab], Memc[outtab], phu_copied) + otp = tbtopn (Memc[outtab], NEW_FILE, NULL) + call tbcdef (otp, ocpx, + outcolx, "", "", TY_DOUBLE, 1, 1) + call tbcdef (otp, ocpy, + outcoly, "histogram", "", TY_INT, 1, 1) + call tbtcre (otp) + + # Put info records in the header. + call tbhadt (otp, "intable", Memc[intab]) + call tbhadt (otp, "colname", colname) + call tbhadi (otp, "nrows", nrows) + + # Write the values into the output table, and close it. + call tbcptd (otp, ocpx, Memd[val], 1, nbins) + call tbcpti (otp, ocpy, Memi[counts], 1, nbins) + call tbtclo (otp) + } + call tbtclo (itp) + + call mfree (counts, TY_INT) + call mfree (val, TY_DOUBLE) + } + call tbnclose (list1) + if ( ! listout ) + call tbnclose (list2) + call sfree (sp) +end + +# th_limits -- get limits for histogram +# This routine determines the lower and upper limits of data values for +# making a histogram. If either of the input values v1 or v2 is not INDEF +# (i.e. if it was specified by the user), then that value is returned as +# vlow or vhigh respectively. If either or both are INDEF the minimum and +# maximum values in the table column are gotten, and the minimum and maximum +# are extended a little to ensure that the endpoints are included in the +# histogram. The range is extended by (max - min) / (nbins - 1) / 2 +# on each end. The parameters nbins, vlow, vhigh, and dx may be updated. + +procedure th_limits (tp, cptr, range_str, + nbins, vlow, vhigh, dx, clow, chigh, + got, find_datamin, find_datamax) + +pointer tp # i: ptr to table descriptor +pointer cptr # i: ptr to column descriptor +char range_str[ARB] # i: range of row numbers +int nbins # io: number of bins +double vlow, vhigh # io: lower and upper limits +double dx # io: bin width +double clow, chigh # i: centers of low and high bins +bool got[NPAR] # i: flags to specify what we have got +bool find_datamin # i: true if we need to find minimum data value +bool find_datamax # i: true if we need to find maximum data value +#-- +double value # an element gotten from the table +double vmin, vmax # min & max values in the column +int nrows # number of rows in table +int row # row number +int ranges[3,MAX_RANGES] # ranges of row numbers +int nvalues # returned by decode_ranges and ignored +int stat # returned by get_next_number +bool done +int decode_ranges(), get_next_number(), tbpsta() + +begin + if (find_datamin || find_datamax) { + + # We must determine either the minimum or maximum or both. + + if (decode_ranges (range_str, ranges, MAX_RANGES, nvalues) != OK) + call error (1, "bad range of row numbers") + nrows = tbpsta (tp, TBL_NROWS) + + # First get initial values for min & max in column. We can't just + # take the first value because it might be INDEF. + row = 0 # initialize get_next_number + stat = get_next_number (ranges, row) # get first row number + done = (stat == EOF) || (row > nrows) + while ( ! done ) { + call tbegtd (tp, cptr, row, value) + if ( IS_INDEFD(value) ) { + # get next row number + stat = get_next_number (ranges, row) + if ((stat == EOF) || (row > nrows)) + call error (1, "all values are INDEF") + } else { + vmin = value + vmax = value + done = true + } + } + + # Update min & max values. + stat = get_next_number (ranges, row) # get next row number + done = (stat == EOF) || (row > nrows) + while ( ! done ) { + call tbegtd (tp, cptr, row, value) + if ( !IS_INDEFD(value) ) { + if (value < vmin) + vmin = value + if (value > vmax) + vmax = value + } + stat = get_next_number (ranges, row) # get next row number + if ((stat == EOF) || (row > nrows)) + done = true + } + + # Update parameter values. + call th_update (vmin, vmax, nbins, vlow, vhigh, dx, clow, chigh, + got, find_datamin, find_datamax) + } +end + +# th_mk_hist -- make the histogram + +procedure th_mk_hist (tp, cptr, nbins, vlow, vhigh, dx, range_str, + val, counts, nrows) + +pointer tp # i: ptr to table descriptor +pointer cptr # i: ptr to column descriptor +int nbins # i: number of bins +double vlow # i: min value for histogram +double vhigh # i: max value for histogram +double dx # i: bin width +char range_str[ARB] # i: range of row numbers +double val[nbins] # o: array of values at center of bins +int counts[nbins] # o: the histogram, array of counts within bins +int nrows # o: number of rows in range_str and value within limits +#-- +double value # an element gotten from the table +int bin # bin number for output +int totalrows # total number of rows in table +int row # row number +int i +int ranges[3,MAX_RANGES] # ranges of row numbers +int nvalues # returned by decode_ranges and ignored +int stat # returned by get_next_number +bool done +int decode_ranges(), get_next_number(), tbpsta() + +begin + totalrows = tbpsta (tp, TBL_NROWS) + + # Initialize the range of row numbers. + if (decode_ranges (range_str, ranges, MAX_RANGES, nvalues) != OK) + call error (1, "bad range of row numbers") + + do i = 1, nbins { + val[i] = vlow + (i - 0.5d0) * dx # value at center of bin + counts[i] = 0 # initialize histogram + } + + nrows = 0 # initialize counter + row = 0 # initialize get_next_number + stat = get_next_number (ranges, row) # get first row number + done = (stat == EOF) || (row > totalrows) + while ( ! done ) { + call tbegtd (tp, cptr, row, value) + if ( ! IS_INDEF(value) ) { + if (value >= vlow && value < vhigh) { + if (dx > 0.d0) + bin = int ((value - vlow) / dx) + 1 + else + bin = 1 + counts[bin] = counts[bin] + 1 + nrows = nrows + 1 + } + } + stat = get_next_number (ranges, row) # get next row number + done = (stat == EOF) || (row > totalrows) + } +end diff --git a/pkg/utilities/nttools/tstat/thoptions.x b/pkg/utilities/nttools/tstat/thoptions.x new file mode 100644 index 00000000..5b9ce639 --- /dev/null +++ b/pkg/utilities/nttools/tstat/thoptions.x @@ -0,0 +1,343 @@ +include "thistogram.h" # defines NPAR, etc. + +# This file contains th_options and th_update. +# +# Phil Hodge, 18-Mar-1994 Subroutines created. + +# th_options -- different options for specifying limits +# There are different ways to specify the limits and bin spacing. This +# routine computes some parameters given others, based on the following: +# +# dx = (vhigh - vlow) / nbins +# dx = (chigh - clow) / (nbins - 1) +# clow = vlow + dx / 2 +# chigh = vhigh - dx / 2 +# +# Note that vlow and vhigh correspond to task parameters lowval and highval. + +procedure th_options (nbins, vlow, vhigh, dx, clow, chigh, + got, find_datamin, find_datamax) + +int nbins # io: number of bins +double vlow, vhigh # io: lower and upper limits +double dx # io: bin width +double clow, chigh # io: centers of low and high bins +bool got[NPAR] # o: flags to specify what we have got +bool find_datamin # o: true if we need to find minimum data value +bool find_datamax # o: true if we need to find maximum data value +#-- +bool fp_equald() + +begin + # These flags will be reset below if we determine the values. + got[NBINS] = !IS_INDEFI(nbins) + got[VLOW] = !IS_INDEFD(vlow) + got[VHIGH] = !IS_INDEFD(vhigh) + got[DX] = !IS_INDEFD(dx) + got[CLOW] = !IS_INDEFD(clow) + got[CHIGH] = !IS_INDEFD(chigh) + + # Check whether low value is greater than high value. + if (got[VLOW] && got[VHIGH]) + if (vlow > vhigh) + call error (1, "lowval must not be larger than highval") + if (got[CLOW] && got[CHIGH]) + if (clow > chigh) + call error (1, "clow must not be larger than chigh") + + # Further checking. + if (got[VLOW] && got[CLOW]) + if (vlow > clow) + call error (1, "lowval must not be larger than clow") + if (got[CHIGH] && got[VHIGH]) + if (chigh > vhigh) + call error (1, "chigh must not be larger than highval") + if (got[VLOW] && got[CHIGH]) + if (vlow > chigh) + call error (1, "lowval must not be larger than chigh") + if (got[CLOW] && got[VHIGH]) + if (clow > vhigh) + call error (1, "clow must not be larger than highval") + + # Set flags to specify what (if anything) we must get from the data. + # These may be reset below. + find_datamin = (!got[VLOW] && !got[CLOW]) + find_datamax = (!got[VHIGH] && !got[CHIGH]) + + if (got[DX]) { + + # Was the lower limit specified by the user? + if (got[CLOW]) { + if (got[VLOW]) { + if (!fp_equald (clow, vlow + dx/2.d0)) + call error (1, "values of dx, clow, lowval conflict") + } else { + vlow = clow - dx / 2.d0 + got[VLOW] = true + } + } else if (got[VLOW]) { + clow = vlow + dx / 2.d0 + got[CLOW] = true + } + + # Was the upper limit specified? + if (got[CHIGH]) { + if (got[VHIGH]) { + if (!fp_equald (chigh, vhigh - dx/2.d0)) + call error (1, "values of dx, chigh, highval conflict") + } else { + vhigh = chigh + dx / 2.d0 + got[VHIGH] = true + } + } else if (got[VHIGH]) { + chigh = vhigh - dx / 2.d0 + got[CHIGH] = true + } + + # Was the number of bins specified? + if (got[NBINS]) { + if (got[VLOW] && got[VHIGH]) { + if (!fp_equald (vhigh - vlow, dx * nbins)) + call error (1, "specified values for limits conflict") + } else if (got[VLOW]) { + vhigh = vlow + dx * nbins + chigh = vhigh - dx / 2.d0 + got[VHIGH] = true + got[CHIGH] = true + find_datamax = false + } else if (got[VHIGH]) { + vlow = vhigh - dx * nbins + clow = vlow + dx / 2.d0 + got[VLOW] = true + got[CLOW] = true + find_datamin = false + } + + } else if (got[VLOW] && got[VHIGH]) { + nbins = nint ((vhigh - vlow) / dx) + if (nbins * dx < vhigh - vlow) + nbins = nbins + 1 # round up + got[NBINS] = true + } + + } else if (got[NBINS]) { # but we don't have dx + + if (nbins == 1) { + if (!got[VLOW] && !got[VHIGH] && (got[CLOW] || got[CHIGH])) { + call eprintf ( + "nbins = 1, clow or chigh was specified, but dx was not.\n") + call error (1, "must specify dx for this case") + } + } + + if (got[VLOW] && got[VHIGH]) { + + dx = (vhigh - vlow) / double(nbins) + got[DX] = true + if (got[CLOW]) { + if (!fp_equald (clow, vlow + dx/2.d0)) + call error (1, "clow conflicts with other parameters") + } else { + clow = vlow + dx / 2.d0 + got[CLOW] = true + } + if (got[CHIGH]) { + if (!fp_equald (chigh, vhigh - dx/2.d0)) + call error (1, "chigh conflicts with other parameters") + } else { + chigh = vhigh - dx / 2.d0 + got[CHIGH] = true + } + + } else if (got[CLOW] && got[CHIGH]) { + + if (nbins == 1) { + if (!fp_equald (clow, chigh)) + call error (1, "nbins = 1, but clow != chigh") + } else { + dx = (chigh - clow) / (double(nbins) - 1.d0) + got[DX] = true + if (got[VLOW]) { + if (!fp_equald (vlow, clow - dx/2.d0)) + call error (1, + "lowval conflicts with other parameters") + } else { + vlow = clow - dx / 2.d0 + got[VLOW] = true + } + if (got[VHIGH]) { + if (!fp_equald (vhigh, chigh + dx/2.d0)) + call error (1, + "highval conflicts with other parameters") + } else { + vhigh = chigh + dx / 2.d0 + got[VHIGH] = true + } + } + + } else if (got[CLOW] && got[VLOW]) { + + dx = (clow - vlow) * 2.d0 + vhigh = vlow + dx * nbins + chigh = vhigh - dx / 2.d0 + got[DX] = true + got[VHIGH] = true + got[CHIGH] = true + find_datamax = false + + } else if (got[CHIGH] && got[VHIGH]) { + + dx = (vhigh - chigh) * 2.d0 + vlow = vhigh - dx * nbins + clow = vlow + dx / 2.d0 + got[DX] = true + got[VLOW] = true + got[CLOW] = true + find_datamin = false + + } else if (got[CLOW] && got[VHIGH]) { + + dx = (vhigh - clow) / (double(nbins) - 0.5d0) + vlow = vhigh - dx * nbins + chigh = vhigh - dx / 2.d0 + got[DX] = true + got[VLOW] = true + got[CHIGH] = true + + } else if (got[VLOW] && got[CHIGH]) { + + dx = (chigh - vlow) / (double(nbins) - 0.5d0) + clow = vlow + dx / 2.d0 + vhigh = vlow + dx * nbins + got[DX] = true + got[CLOW] = true + got[VHIGH] = true + + } + + } else if (got[CLOW] && got[VLOW]) { # but neither dx nor nbins + + dx = (clow - vlow) * 2.d0 + got[DX] = true + + } else if (got[CHIGH] && got[VHIGH]) { # but neither dx nor nbins + + dx = (vhigh - chigh) * 2.d0 + got[DX] = true + + } else { + call error (1, "you must specify either nbins or dx (or both)") + } +end + +# th_update -- update the limits +# We now have the minimum and maximum data values from the table, +# so we can fill in the values that the user did not specify. +# We need nbins, vlow, vhigh, and dx. The values of clow and chigh +# are not modified, even if they are still INDEF; the array of flags +# (got) must not be modified, as these flags are used for different +# tables if there is more than one in the input list. + +procedure th_update (vmin, vmax, nbins, vlow, vhigh, dx, clow, chigh, + got, find_datamin, find_datamax) + +double vmin, vmax # i: min and max data values for current table +int nbins # io: number of bins +double vlow, vhigh # io: lower and upper limits +double dx # io: bin width +double clow, chigh # i: centers of low and high bins +bool got[NPAR] # i: flags that specify what parameters we already have +bool find_datamin # i: true if we had to find minimum data value +bool find_datamax # i: true if we had to find maximum data value +#-- +double delta # for expanding the range to include endpoints + +begin + if (find_datamin && find_datamax) { + + # Center the data within the range. We do have either + # dx or nbins or both. + if (got[DX] && got[NBINS]) { + delta = (dx * nbins - (vmax - vmin)) / 2.d0 + } else if (got[NBINS]) { + if (nbins == 1) + delta = (vmax - vmin) / 100.d0 # 100 is arbitrary + else + delta = (vmax - vmin) / (nbins - 1.d0) / 2.d0 + } else if (got[DX]) { + nbins = nint ((vmax - vmin) / dx) + if (nbins * dx <= vmax - vmin) + nbins = nbins + 1 # round up + delta = (dx * nbins - (vmax - vmin)) / 2.d0 + } + vlow = vmin - delta + vhigh = vmax + delta + if (!got[DX]) + dx = (vhigh - vlow) / nbins + + } else if (find_datamin) { + + # We don't have both dx and nbins. If we did, we would have + # calculated vlow from vhigh, dx, and nbins. + if (got[DX]) { + + nbins = nint ((vhigh - vmin) / dx) # vhigh is known + if (nbins * dx <= vhigh - vmin) + nbins = nbins + 1 # round up + vlow = vhigh - dx * nbins + + } else if (got[NBINS]) { + + if (got[VHIGH]) { + if (nbins == 1) + delta = (vhigh - vmin) / 100.d0 # 100 is arbitrary + else + delta = (vhigh - vmin) / (nbins - 1.d0) / 2.d0 + vlow = vmin - delta + dx = (vhigh - vlow) / nbins + } else { # we have chigh but not vhigh + if (nbins == 1) { + vlow = vmin # this case doesn't make sense + vhigh = chigh + (chigh - vmin) + dx = vhigh - vlow + } else { # set clow = vmin + dx = (chigh - vmin) / (nbins - 1.d0) + vlow = vmin - dx / 2.d0 + vhigh = chigh + dx / 2.d0 + } + } + } + + } else if (find_datamax) { + + # For this case as well, we don't have both dx and nbins. + if (got[DX]) { + + nbins = nint ((vmax - vlow) / dx) # vlow is known + if (nbins * dx <= vmax - vlow) + nbins = nbins + 1 # round up + vhigh = vlow + dx * nbins + + } else if (got[NBINS]) { + + if (got[VLOW]) { + if (nbins == 1) + delta = (vmax - vlow) / 100.d0 # 100 is arbitrary + else + delta = (vmax - vlow) / (nbins - 1.d0) / 2.d0 + vhigh = vmax + delta + dx = (vhigh - vlow) / nbins + } else { # we have clow but not vlow + if (nbins == 1) { + vhigh = vmax # this case doesn't make sense + vlow = clow - (vmax - clow) + dx = vhigh - vlow + } else { # set chigh = vmax + dx = (vmax - clow) / (nbins - 1.d0) + vlow = vmin - dx / 2.d0 + vhigh = chigh + dx / 2.d0 + } + } + } + } +end diff --git a/pkg/utilities/nttools/tstat/tstat.x b/pkg/utilities/nttools/tstat/tstat.x new file mode 100644 index 00000000..5ef2b435 --- /dev/null +++ b/pkg/utilities/nttools/tstat/tstat.x @@ -0,0 +1,465 @@ +include +include # to check whether input or output is redirected +include + +define MAX_RANGES (SZ_LINE/2) # max number of ranges of row numbers +define NUM_COL 8 # number of output columns + +# tstat -- get statistics for a table column +# This task gets the mean, standard deviation, median, and minimum & +# maximum values for a table column. +# +# Phil Hodge, 8-Dec-1988 Task created. +# Phil Hodge, 14-Mar-1989 Also compute the median; fix bug in std dev. +# Phil Hodge, 27-May-1992 Print INDEF if no values in range. +# Phil Hodge, 31-Jul-1992 Print column name after table name. +# Phil Hodge, 11-Jan-1992 Use asrtd instead of asokd for median if nr is even. +# Phil Hodge, 3-Oct-1995 Modify to use tbn instead of fnt. +# Phil Hodge, 25-Apr-1997 Use asrtd instead of asokd regardless of nr. +# Phil Hodge, 26-Mar-1998 Get all elements of array columns; ignore the +# column parameter if an input table has only one column. +# Phil Hodge, 8-Jun-1999 Set input/output to STDIN/STDOUT if redirected. +# Phil Hodge, 2-Jan-2001 If the input was redirected, and one command-line +# argument was specified, take that argument to be the +# column name rather than the table name. + +procedure tstat() + +pointer inlist # scratch for list of input table names +char cl_colname[SZ_COLNAME] # column name gotten from cl parameter +double lowlim # lower & upper limits for histogram +double highlim # lower & upper limits for histogram +pointer range_string # string which gives ranges of row numbers +char nam_table[SZ_FNAME] # column name for table name +char nam_name[SZ_COLNAME] # column name for column name +char nam_mean[SZ_COLNAME] # column name for mean +char nam_stddev[SZ_COLNAME] # column name for standard deviation +char nam_med[SZ_COLNAME] # column name for median +char nam_min[SZ_COLNAME] # column name for minimum +char nam_max[SZ_COLNAME] # column name for maximum +char nam_nrows[SZ_COLNAME] # column name for number of good rows +#-- +pointer list1 # for list of input tables +pointer sp +pointer itp, otp # ptr to table descriptor +pointer cptr # ptr to column descriptor +pointer ocp[NUM_COL] # ptrs to col descriptors for output columns +pointer intab, outtab # scr for names of input & output tables +char colname[SZ_COLNAME] # column name +double vmean # mean value +double vstddev # standard deviation of values +double vmedian # median value +double vmin, vmax # minimum & maximum values +int row # output row number +int nrows # number of rows included and not INDEF +int ntables # number of tables in input list +bool listout # ASCII output? +bool tabout # table output? +bool new_table # true if output table does not already exist +int nargs # number of command-line arguments +bool in_redir # is input redirected? +int clgeti() +double clgetd() +int fstati() +pointer tbnopen() +int tbnget(), tbnlen() +pointer tbtopn() +pointer tbcnum() +int tbtacc(), tbpsta() +bool streq() + +begin + # Allocate scratch for lists of names and for table names. + call smark (sp) + call salloc (inlist, SZ_LINE, TY_CHAR) + call salloc (intab, SZ_LINE, TY_CHAR) + call salloc (outtab, SZ_LINE, TY_CHAR) + call salloc (range_string, SZ_LINE, TY_CHAR) + + # Get task parameters. + + nargs = clgeti ("$nargs") + in_redir = fstati (STDIN, F_REDIR) == YES + + if (in_redir) + call strcpy ("STDIN", Memc[inlist], SZ_LINE) + else + call clgstr ("intable", Memc[inlist], SZ_LINE) + + if (fstati (STDOUT, F_REDIR) == YES) + call strcpy ("STDOUT", Memc[outtab], SZ_LINE) + else + call clgstr ("outtable", Memc[outtab], SZ_LINE) + + cl_colname[1] = EOS # initial value + lowlim = clgetd ("lowlim") # these limits may be INDEF + highlim = clgetd ("highlim") + call clgstr ("rows", Memc[range_string], SZ_LINE) + + # ASCII output? table output? create a new output table? + listout = streq (Memc[outtab], "STDOUT") + if ( listout || (Memc[outtab] == EOS) ) { + tabout = false + } else { + tabout = true + new_table = (tbtacc (Memc[outtab]) == NO) + } + + if (tabout) { + call clgstr ("n_tab", nam_table, SZ_FNAME) + call clgstr ("n_nam", nam_name, SZ_COLNAME) + call clgstr ("n_nrows", nam_nrows, SZ_COLNAME) + call clgstr ("n_mean", nam_mean, SZ_COLNAME) + call clgstr ("n_stddev", nam_stddev, SZ_COLNAME) + call clgstr ("n_median", nam_med, SZ_COLNAME) + call clgstr ("n_min", nam_min, SZ_COLNAME) + call clgstr ("n_max", nam_max, SZ_COLNAME) + } + + # Expand the input table list. + list1 = tbnopen (Memc[inlist]) + + ntables = tbnlen (list1) + + if (listout) { + row = 0 # just to have a definite value + if (ntables > 1) { + call printf ("# nrows") + call printf (" mean stddev median") + call printf (" min max\n\n") + } + } else if (tabout) { + # Create output table (or open existing table) & define columns. + if (new_table) + otp = tbtopn (Memc[outtab], NEW_FILE, NULL) + else + otp = tbtopn (Memc[outtab], READ_WRITE, NULL) + + call tbcfnd (otp, nam_table, ocp[1], 1) + call tbcfnd (otp, nam_name, ocp[2], 1) + call tbcfnd (otp, nam_nrows, ocp[3], 1) + call tbcfnd (otp, nam_mean, ocp[4], 1) + call tbcfnd (otp, nam_stddev, ocp[5], 1) + call tbcfnd (otp, nam_med, ocp[6], 1) + call tbcfnd (otp, nam_min, ocp[7], 1) + call tbcfnd (otp, nam_max, ocp[8], 1) + + if (ocp[1] == NULL) + call tbcdef (otp, ocp[1], + nam_table, "", "", -SZ_FNAME, 1, 1) + if (ocp[2] == NULL) + call tbcdef (otp, ocp[2], + nam_name, "", "", -SZ_COLNAME, 1, 1) + if (ocp[3] == NULL) + call tbcdef (otp, ocp[3], + nam_nrows, "", "", TY_INT, 1, 1) + if (ocp[4] == NULL) + call tbcdef (otp, ocp[4], + nam_mean, "", "", TY_DOUBLE, 1, 1) + if (ocp[5] == NULL) + call tbcdef (otp, ocp[5], + nam_stddev, "", "", TY_DOUBLE, 1, 1) + if (ocp[6] == NULL) + call tbcdef (otp, ocp[6], + nam_med, "", "", TY_DOUBLE, 1, 1) + if (ocp[7] == NULL) + call tbcdef (otp, ocp[7], + nam_min, "", "", TY_DOUBLE, 1, 1) + if (ocp[8] == NULL) + call tbcdef (otp, ocp[8], + nam_max, "", "", TY_DOUBLE, 1, 1) + if (new_table) + call tbtcre (otp) + + row = tbpsta (otp, TBL_NROWS) # append to whatever is there + } + + # Do for each input table. + while (tbnget (list1, Memc[intab], SZ_LINE) != EOF) { + + itp = tbtopn (Memc[intab], READ_ONLY, NULL) + if (tbpsta (itp, TBL_NCOLS) == 1) { + cptr = tbcnum (itp, 1) + call tbcigt (cptr, TBL_COL_NAME, colname, SZ_COLNAME) + } else { + if (cl_colname[1] == EOS) { + if (nargs == 1 && in_redir) { + # in this case, the one argument should be column name + call clgstr ("intable", cl_colname, SZ_COLNAME) + # update par file + call clpstr ("intable", "STDIN") + call clpstr ("column", cl_colname) + } else { + call clgstr ("column", cl_colname, SZ_COLNAME) + } + } + call strcpy (cl_colname, colname, SZ_COLNAME) + call tbcfnd (itp, colname, cptr, 1) + } + if (cptr == NULL) { + call tbtclo (itp) + call eprintf ("column %s not found in %s\n") + call pargstr (colname) + call pargstr (Memc[intab]) + next + } + row = row + 1 + + if (listout) { + call printf ("# %s %s\n") + call pargstr (Memc[intab]) + call pargstr (colname) + if (ntables == 1) { + call printf ("# nrows") + call printf (" mean stddev median") + call printf (" min max\n") + } + } + + # Get statistics. + iferr { + call ts_values (itp, cptr, Memc[range_string], lowlim, highlim, + vmean, vstddev, vmedian, vmin, vmax, nrows) + } then { + call erract (EA_WARN) + next + } + + if (listout) { + + call printf ("%5d %17.10g %13.6g %13.6g %13.6g %13.6g\n") + call pargi (nrows) + call pargd (vmean) + call pargd (vstddev) + call pargd (vmedian) + call pargd (vmin) + call pargd (vmax) + + } else if (tabout) { + + # Write the values into the output table. + call tbeptt (otp, ocp[1], row, Memc[intab]) + call tbeptt (otp, ocp[2], row, colname) + call tbepti (otp, ocp[3], row, nrows) + call tbeptd (otp, ocp[4], row, vmean) + call tbeptd (otp, ocp[5], row, vstddev) + call tbeptd (otp, ocp[6], row, vmedian) + call tbeptd (otp, ocp[7], row, vmin) + call tbeptd (otp, ocp[8], row, vmax) + } + + call tbtclo (itp) # close current input table + } + + # Close the output table. It may be that nothing was written to it. + if (tabout) + call tbtclo (otp) + + # Save the results (from the last input table) in cl parameters. + call clputi ("nrows", nrows) + call clputd ("mean", vmean) + call clputd ("stddev", vstddev) + call clputd ("median", vmedian) + call clputd ("vmin", vmin) + call clputd ("vmax", vmax) + + call tbnclose (list1) + call sfree (sp) +end + +# ts_values -- get statistics for a table column +# This routine gets the mean, standard deviation, minimum and maximum +# values for a table column. If lower and/or upper cutoff limits were +# specified (i.e. are not INDEF) then values outside that range will not +# be included in the statistics. INDEF values are also not included. + +procedure ts_values (tp, cptr, range_str, lowlim, highlim, + vmean, vstddev, vmedian, vmin, vmax, nrows) + +pointer tp # i: ptr to table descriptor +pointer cptr # i: ptr to column descriptor +char range_str[ARB] # i: range of row numbers +double lowlim # i: lower cutoff of values to be included +double highlim # i: upper cutoff of values to be included +double vmean # o: mean value +double vstddev # o: standard deviation of values +double vmedian # o: median value +double vmin # o: minimum value +double vmax # o: maximum value +int nrows # o: number of rows included in the statistics +#-- +pointer sp +pointer val # scratch for array of values (for median) +pointer descrip # column selector descriptor +double value # an element gotten from the table +double sum, sumsq # for accumulating sums +double smin, smax # temp min & max +double diff # current value minus first good value +int all_elem # total number of elements in column +int selrows # number of selected rows +int nelem # number of elements in one cell +int nret # number returned (ignored) +int nr # current number of rows +int row # row number +int ranges[3,MAX_RANGES] # ranges of row numbers +int nvalues # returned by decode_ranges and ignored +int stat # returned by get_next_number +int i, j # loop indexes +bool chklow, chkhi # were low (high) limits specified? +bool val_ok # is current value within limits? +bool done # loop-termination flag +int decode_ranges(), get_next_number() +int tbagtd() +errchk tbagtd, tbegtd, tcs_rdaryd + +begin + if (decode_ranges (range_str, ranges, MAX_RANGES, nvalues) != OK) { + call eprintf ("rows = `%s'\n") + call pargstr (range_str) + call error (1, "Range of row numbers is invalid.") + } + + # Get the number of elements per table cell and the number of + # rows selected using row-selector syntax (as opposed to using + # the 'rows' task parameter). + call tbcnel1 (tp, cptr, descrip, nelem, selrows) + + # Find out how many rows there are in the table, restricted by + # either a row selector or the 'rows' task parameter, or both. + if (range_str[1] == '-' || range_str[1] == EOS) { + all_elem = selrows * nelem + } else { + # Count the number of rows specified. + i = 0 # count of row numbers + row = 0 # initialize get_next_number + done = false + while (!done) { + stat = get_next_number (ranges, row) + if (stat == EOF || row > selrows) + done = true + else + i = i + 1 + } + all_elem = i * nelem + } + + # Allocate scratch space to hold an entire column. + call smark (sp) + call salloc (val, all_elem, TY_DOUBLE) + + row = 0 # reinitialize get_next_number + stat = get_next_number (ranges, row) + done = (stat == EOF || row > selrows) + + # Get the data. + i = 1 + while (!done) { + + if (descrip == NULL) { + if (nelem == 1) + call tbegtd (tp, cptr, row, Memd[val+i-1]) + else + nret = tbagtd (tp, cptr, row, Memd[val+i-1], 1, nelem) + } else { + call tcs_rdaryd (tp, descrip, row, all_elem-i+1, + nret, Memd[val+i-1]) + } + + i = i + nelem + + stat = get_next_number (ranges, row) + done = (stat == EOF || row > selrows) + } + if (all_elem != i - 1) + call error (1, "not all elements read from column") + + chklow = ! IS_INDEFD(lowlim) + chkhi = ! IS_INDEFD(highlim) + + # Check which values to include. + sum = 0.d0 + nr = 0 + do i = 0, all_elem-1 { # zero indexed + value = Memd[val+i] + if (!IS_INDEFD(value)) { + val_ok = true # an initial value + if (chkhi && (value > highlim)) { + val_ok = false + Memd[val+i] = INDEFD + } + if (chklow && (value < lowlim)) { + val_ok = false + Memd[val+i] = INDEFD + } + if (val_ok) { + nr = nr + 1 + sum = sum + value + } + } + } + + if (nr < 1) { + # No rows with valid data, so set the output to INDEF. + nrows = 0 + vmean = INDEFD + vstddev = INDEFD + vmedian = INDEFD + vmin = INDEFD + vmax = INDEFD + return + } else { + # Assign two of the output values. + nrows = nr + vmean = sum / double(nr) + } + + # Move good data to the beginning of the array. + if (nr < all_elem) { + j = 0 + do i = 0, all_elem-1 { # zero indexed + if (!IS_INDEFD(Memd[val+i])) { + Memd[val+j] = Memd[val+i] + j = j + 1 + } + } + } + + # Find the min, max, standard deviation of the good values. + sumsq = 0.d0 + smin = Memd[val] + smax = Memd[val] + do i = 0, nr-1 { # zero indexed + value = Memd[val+i] + diff = value - vmean + sumsq = sumsq + diff * diff + if (value < smin) + smin = value + if (value > smax) + smax = value + } + + # Assign output values. + + vmin = smin + vmax = smax + + if (nr > 1) + vstddev = sqrt (sumsq / double(nr-1)) + else + vstddev = INDEFD + + # Determine the median. If there are an even number of values, the + # middle two are averaged. + if (nr < 3) { + vmedian = vmean + } else { + call asrtd (Memd[val], Memd[val], nr) + if (nr / 2 * 2 == nr) { # even number of values? + vmedian = (Memd[val+nr/2-1] + Memd[val+nr/2]) / 2.d0 + } else { + vmedian = Memd[val+nr/2] + } + } + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/ttranspose.par b/pkg/utilities/nttools/ttranspose.par new file mode 100644 index 00000000..843b5890 --- /dev/null +++ b/pkg/utilities/nttools/ttranspose.par @@ -0,0 +1,6 @@ +intable,s,a,"",,,"input tables" +outtable,s,a,"",,,"output tables" +action,s,a,"t",,,"operations (t,h,v) to perform" +verbose,b,h,yes,,,"print table names?" +Version,s,h,"30Nov94",,,"date of installation" +mode,s,h,"al" diff --git a/pkg/utilities/nttools/ttranspose/mkpkg b/pkg/utilities/nttools/ttranspose/mkpkg new file mode 100644 index 00000000..6118a47e --- /dev/null +++ b/pkg/utilities/nttools/ttranspose/mkpkg @@ -0,0 +1,11 @@ +# Update the ttranspose application code in the ttools package library + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + ttranspose.x + ttrflip.x + ; diff --git a/pkg/utilities/nttools/ttranspose/ttranspose.x b/pkg/utilities/nttools/ttranspose/ttranspose.x new file mode 100644 index 00000000..1bf99d9e --- /dev/null +++ b/pkg/utilities/nttools/ttranspose/ttranspose.x @@ -0,0 +1,419 @@ +include # for EA_WARN +include # to check whether input or output is redirected +include + +# ttranspose -- transpose or flip a table +# This task can be used to transpose a table so that input rows become +# output columns and input columns become output rows. Another option +# is to flip the table horizontally, that is, the first input column is +# the last output column. Finally, the table can be flipped vertically, +# i.e., the first input row is the last output row. Any combination of +# these operations may be performed. +# +# Phil Hodge, 30-Nov-1994 Task created. +# Phil Hodge, 4-Oct-1995 Modify to use tbn instead of fnt. +# Phil Hodge, 12-Jun-1998 Initialize maxwidth using tbcftl in ttr_compare. +# Phil Hodge, 8-Apr-1999 Call tbfpri. +# Phil Hodge, 8-Jun-1999 Set input/output to STDIN/STDOUT if redirected. + +procedure ttranspose() + +pointer innames # scratch for names of input tables +pointer outnames # scratch for names of output tables +pointer action # scratch for operations to perform +bool verbose # print table names? +#-- +pointer sp +pointer ilist, olist # tbn pointers for input & output lists +pointer intable # scratch for name of an input table +pointer outtable # scratch for name of an output table +pointer itp, otp # pointers to input & output table structs +pointer icp, ocp # pointers to arrays of column descriptors +int op[2] # mapping of (columns,rows) from input to output +int dtype # data type of columns +int nelem # number of elements in array +int irows, orows # number of rows in input, output tables +int icols, ocols # number of columns in input, output tables +int i # loop index +int junk +int num_out # number of output table names +int phu_copied # set by tbfpri and ignored +bool transpose # true if table will be transposed, not just flipped +bool to_stdout # true if output is to STDOUT +bool clgetb(), streq() +int fstati() +pointer tbnopen() +int tbnlen(), tbnget() +pointer tbtopn(), tbcnum() +int tbpsta() +errchk ttr_compare, tbfpri, ttr_create, ttr_trans, ttr_flip +string SKIP "Table %s will be skipped:\n" + +begin + call smark (sp) + call salloc (innames, SZ_LINE, TY_CHAR) + call salloc (outnames, SZ_LINE, TY_CHAR) + call salloc (intable, SZ_LINE, TY_CHAR) + call salloc (outtable, SZ_LINE, TY_CHAR) + call salloc (action, SZ_LINE, TY_CHAR) + + if (fstati (STDIN, F_REDIR) == YES) + call strcpy ("STDIN", Memc[innames], SZ_LINE) + else + call clgstr ("intable", Memc[innames], SZ_LINE) + + if (fstati (STDOUT, F_REDIR) == YES) + call strcpy ("STDOUT", Memc[outnames], SZ_LINE) + else + call clgstr ("outtable", Memc[outnames], SZ_LINE) + + call clgstr ("action", Memc[action], SZ_LINE) + verbose = clgetb ("verbose") + + # Interpret the list of operations. + call ttr_opcode (Memc[action], op, transpose) + + ilist = tbnopen (Memc[innames]) + olist = tbnopen (Memc[outnames]) + + to_stdout = false # may be updated below + num_out = tbnlen (olist) + # Get the first output name now, and then rewind the list. + junk = tbnget (olist, Memc[outtable], SZ_LINE) + call tbnrew (olist) + + if (tbnlen (ilist) != num_out) { + if (num_out == 1 && streq (Memc[outtable], "STDOUT")) { + # It's OK to have multiple input tables and just one output + # if the latter is STDOUT. + to_stdout = true + } else { + call tbnclose (olist) + call tbnclose (ilist) + call error (1, "Input and output lists not the same length.") + } + } + + # Do for each table in the list. + while (tbnget (ilist, Memc[intable], SZ_LINE) != EOF) { + if (num_out > 1) + junk = tbnget (olist, Memc[outtable], SZ_LINE) + + # Open input table and get number of rows and columns. + itp = tbtopn (Memc[intable], READ_ONLY, NULL) + irows = tbpsta (itp, TBL_NROWS) + icols = tbpsta (itp, TBL_NCOLS) + call tbtnam (itp, Memc[intable], SZ_LINE) # get full table name + + # Allocate space for pointers to column descriptors. + call malloc (icp, icols, TY_POINTER) + + # Get column pointers for input table. + do i = 1, icols + Memi[icp+i-1] = tbcnum (itp, i) + + iferr { + # Check that data types of columns are all the same. + call ttr_compare (itp, Memi[icp], icols, + transpose, dtype, nelem) + + # Create output table. + call tbfpri (Memc[intable], Memc[outtable], phu_copied) + call ttr_create (itp, otp, Memi[icp], ocp, Memc[outtable], + op, transpose, irows, icols, orows, ocols, dtype, nelem) + } then { + call mfree (icp, TY_POINTER) + call tbtclo (itp) + call eprintf (SKIP) + call pargstr (Memc[intable]) + call erract (EA_WARN) + next + } + + if (verbose) { + call printf ("%s --> %s\n") + call pargstr (Memc[intable]) + call pargstr (Memc[outtable]) + call flush (STDOUT) + } + + # Copy table data. + iferr { + if (transpose) { + call ttr_trans (itp, otp, Memi[icp], Memi[ocp], + irows, icols, orows, ocols, op, dtype, nelem) + } else { + call ttr_flip (itp, otp, Memi[icp], Memi[ocp], + irows, icols, op) + } + } then { + call mfree (ocp, TY_POINTER) + call mfree (icp, TY_POINTER) + call tbtclo (otp) + call tbtclo (itp) + call tbtdel (Memc[outtable]) + call eprintf (SKIP) + call pargstr (Memc[intable]) + call erract (EA_WARN) + next + } + + call mfree (ocp, TY_POINTER) + call mfree (icp, TY_POINTER) + iferr { + call tbtclo (otp) + } then { + call eprintf (SKIP) + call pargstr (Memc[intable]) + call erract (EA_WARN) + } + call tbtclo (itp) + } + + call tbnclose (olist) + call tbnclose (ilist) + call sfree (sp) +end + +procedure ttr_opcode (action, op, transpose) + +char action[ARB] # i: list of operations to perform +int op[2] # o: combined operations +bool transpose # o: true if table will be transposed, not just flipped +#-- +int i +int prev[2] # previous op +int slen # length of string +int strlen() + +begin + slen = strlen (action) + + prev[1] = 1 # initial values + prev[2] = 2 + + do i = 1, slen { + if (action[i] == 't' || action[i] == '/') { + # transpose + op[1] = prev[2] + op[2] = prev[1] + } else if (action[i] == 'h' || action[i] == '-') { + # flip horizontally, i.e. first column <--> last col + op[1] = -prev[1] + op[2] = prev[2] + } else if (action[i] == 'v' || action[i] == '|') { + # flip vertically, i.e. first row <--> last row + op[1] = prev[1] + op[2] = -prev[2] + } else if (action[i] == ',' || action[i] == ' ') { + ; + } else { + call error (1, "'action' must use only t, h, v") + } + prev[1] = op[1] # save for next loop + prev[2] = op[2] + } + + # After all the operations, will we actually transpose the table, + # or just flip it? + transpose = (abs (op[1]) == 2) +end + +# ttr_compare -- compare data types and array lengths + +procedure ttr_compare (itp, icp, icols, transpose, dtype, nelem) + +pointer itp # i: pointer to input table struct +pointer icp[icols] # i: array of pointers to input column descriptors +int icols # i: number of columns in input table +bool transpose # i: true if table will be transposed, not just flipped +int dtype # o: data type of columns +int nelem # o: length of array stored at each row,column +#-- +int dtype2, nelem2 # data type and array length of column to compare +int width # width of a particular column +int maxwidth # max width of column in text table +int i +int tbpsta(), tbcigi() + +begin + # Get info about first column so we can compare with other columns. + dtype = tbcigi (icp[1], TBL_COL_DATATYPE) + nelem = tbcigi (icp[1], TBL_COL_LENDATA) + if (dtype == TY_CHAR) { # old style, change it + dtype = -nelem + nelem = 1 + } + + # We don't need to check column data types if we're not actually + # transposing the table. + if (!transpose) + return + + if (tbpsta (itp, TBL_WHTYPE) == TBL_TYPE_TEXT) { + + # For a text table, we can permit different input data types + # if we set the output type to text. + + call tbcftl (icp[1], maxwidth) # maxwidth updated in loop + do i = 2, icols { + + call tbcftl (icp[i], width) # get width of current column + maxwidth = max (maxwidth, width) + + dtype2 = tbcigi (icp[i], TBL_COL_DATATYPE) + if (dtype > 0 && dtype != dtype2) { + # They're not the same; change to char data type. + dtype = -maxwidth + } + } + if (dtype < 0) + dtype = -maxwidth + + } else { # not a text table + + # Compare first column with subsequent columns. + do i = 2, icols { + + dtype2 = tbcigi (icp[i], TBL_COL_DATATYPE) + nelem2 = tbcigi (icp[i], TBL_COL_LENDATA) + if (dtype2 == TY_CHAR) { + dtype2 = -nelem2 + nelem2 = 1 + } + + if (dtype < 0) { + # For character columns, allow different lengths for + # input, but change to maximum length for output. + dtype = min (dtype, dtype2) # max absolute value + + } else if (dtype != dtype2) { + + # Promote real to double, short to int, and bool to + # any other type. + if (dtype == TY_REAL && dtype2 == TY_DOUBLE || + dtype == TY_DOUBLE && dtype2 == TY_REAL) { + dtype = TY_DOUBLE + } else if (dtype == TY_INT && dtype2 == TY_SHORT || + dtype == TY_SHORT && dtype2 == TY_INT) { + dtype = TY_INT + } else if (dtype == TY_BOOL) { + dtype = dtype2 # promote to other type + } else if (dtype2 == TY_BOOL) { + ; # OK to convert to any type + } else { + call error (1, "columns are not all the same data type") + } + } + + if (nelem != nelem2) + call error (1, "column array lengths are not all the same") + } + } +end + +# ttr_create -- create output table +# This routine creates the output table, defines output columns, +# and copies header parameters. +# +# Note the following, which can be a bit confusing. In the case that +# the table is to be flipped horizontally but not transposed, columns are +# defined in the output table in the reverse order from the corresponding +# columns in the input table, but the column pointers themselves are stored +# in their arrays in the same order. That is, icp[i] refers to the same +# column as Memi[ocp+i-1], except of course that icp[i] is in the input +# table and Memi[ocp+i-1] is in the output table. "Same column" means +# that the column descriptions and contents are the same, but the column +# number will in general be different; icp[1] is the first column in the +# input table, Memi[ocp] is the last column in the output table, and they +# will have the same name, etc. + +procedure ttr_create (itp, otp, icp, ocp, outtable, + op, transpose, irows, icols, orows, ocols, dtype, nelem) + +pointer itp # i: pointer to input table struct +pointer otp # o: pointer to output table struct +pointer icp[icols] # i: array of pointers to input column descriptors +pointer ocp # o: pointer to array of pointers to output col descr +char outtable[ARB] # io: name of output table (extension may be appended) +int op[2] # i: operation code +bool transpose # i: true if table will be transposed, not just flipped +int irows # i: number of rows in input table +int icols # i: number of columns in input table +int orows # o: number of rows in output table +int ocols # o: number of columns in output table +int dtype # i: data type of columns +int nelem # i: length of array stored at each row,column +#-- +char colname[SZ_COLNAME] # name of current column +char colunits[SZ_COLUNITS] # units for current column +char colfmt[SZ_COLFMT] # print format for current column +int datatype # data type of current column +int lenarray # number of elements for current column +int lenfmt # space required to print column +int colnum # column number +int i # loop index +int i_start, i_end, i_incr # loop limits for index i +int maxpar # space allocated for header parameters +pointer tbtopn() +int tbpsta() + +begin + # Allocate space for array of column pointers for output table. + if (transpose) { + orows = icols + ocols = irows + } else { # don't transpose + orows = irows + ocols = icols + } + call malloc (ocp, ocols, TY_POINTER) + + # Create output table. + otp = tbtopn (outtable, NEW_FILE, NULL) + if (tbpsta (itp, TBL_WHTYPE) == TBL_TYPE_TEXT) + call tbpset (otp, TBL_WHTYPE, TBL_TYPE_TEXT) + + # Set enough space for all header parameters from input. + maxpar = tbpsta (itp, TBL_MAXPAR) + call tbpset (otp, TBL_MAXPAR, maxpar) + + # Create output columns. + if (transpose) { + + # Assign dummy column names, with null units and default format. + do i = 1, ocols { + call sprintf (colname, SZ_COLNAME, "c%d") + call pargi (i) + call tbcdef (otp, Memi[ocp+i-1], + colname, "", "", dtype, nelem, 1) + } + + } else { + + # We're not transposing, so retain column names, etc. + if (op[1] > 0) { + # retain order of columns + i_start = 1 + i_end = icols + i_incr = 1 + } else { + # flip by defining last column first + i_start = icols + i_end = 1 + i_incr = -1 + } + + do i = i_start, i_end, i_incr { + call tbcinf (icp[i], colnum, colname, colunits, colfmt, + datatype, lenarray, lenfmt) + call tbcdef (otp, Memi[ocp+i-1], + colname, colunits, colfmt, datatype, lenarray, 1) + } + } + call tbtcre (otp) + call tbtnam (otp, outtable, SZ_LINE) # get full table name + + # Copy all header parameters from input to output. + call tbhcal (itp, otp) +end diff --git a/pkg/utilities/nttools/ttranspose/ttrflip.x b/pkg/utilities/nttools/ttranspose/ttrflip.x new file mode 100644 index 00000000..3c008f68 --- /dev/null +++ b/pkg/utilities/nttools/ttranspose/ttrflip.x @@ -0,0 +1,266 @@ +# This file contains ttr_trans and ttr_flip. The former copies data +# from one table to another and transposes rows and columns, while the +# latter copies data without transposing. Either routine may also flip +# rows and/or columns, i.e. first input row to last output row, or first +# input column to last input column. +# +# Phil Hodge, 30-Nov-1994 Subroutines created. + +# ttr_trans -- copy data from input to output +# This routine transposes a table. + +procedure ttr_trans (itp, otp, icp, ocp, + irows, icols, orows, ocols, op, dtype, nelem) + +pointer itp # i: pointer to input table struct +pointer otp # i: pointer to output table struct +pointer icp[icols] # i: array of pointers to input column descriptors +pointer ocp[irows] # i: array of pointers to output column descriptors +int irows # i: number of rows in input table +int icols # i: number of columns in input table +int orows # i: number of rows in output table +int ocols # i: number of columns in output table +int op[2] # i: mapping of (columns,rows) from input to output +int dtype # i: data type of column +int nelem # i: length of array stored at each row,column +#-- +pointer sp +pointer buf # scratch for copying array entries +int clen # length of char string (= -dtype) +int i, j # loop indices for input table +int oi, oj # loop indices for output table +int oj_start # starting value for oj +int oi_incr, oj_incr # increments in oi, oj + +# buffers for copying one element: +pointer cbuf +double dbuf +real rbuf +int ibuf +short sbuf +bool bbuf + +int nret # number of array elements actually read and written +int tbagtd(), tbagtr(), tbagti(), tbagts(), tbagtb(), tbagtt() +errchk tbegtd, tbegtr, tbegti, tbegts, tbegtb, tbegtt, + tbeptd, tbeptr, tbepti, tbepts, tbeptb, tbeptt, + tbagtd, tbagtr, tbagti, tbagts, tbagtb, tbagtt, + tbaptd, tbaptr, tbapti, tbapts, tbaptb, tbaptt + +begin + call smark (sp) + + # Assign values for the beginning and increment for the loops + # on oi and oj. + if (op[1] > 0) { + oi = 1 + oi_incr = 1 + } else { + oi = ocols # = irows + oi_incr = -1 + } + if (op[2] > 0) { + oj_start = 1 + oj_incr = 1 + } else { + oj_start = orows # = icols + oj_incr = -1 + } + + if (dtype < 0) + clen = -dtype + + if (nelem == 1) { + + if (dtype == TY_REAL) { + do j = 1, irows { + oj = oj_start # oj, not oi, because we're transposing + do i = 1, icols { + call tbegtr (itp, icp[i], j, rbuf) + call tbeptr (otp, ocp[oi], oj, rbuf) + oj = oj + oj_incr + } + oi = oi + oi_incr + } + } else if (dtype == TY_DOUBLE) { + do j = 1, irows { + oj = oj_start + do i = 1, icols { + call tbegtd (itp, icp[i], j, dbuf) + call tbeptd (otp, ocp[oi], oj, dbuf) + oj = oj + oj_incr + } + oi = oi + oi_incr + } + } else if (dtype == TY_INT) { + do j = 1, irows { + oj = oj_start + do i = 1, icols { + call tbegti (itp, icp[i], j, ibuf) + call tbepti (otp, ocp[oi], oj, ibuf) + oj = oj + oj_incr + } + oi = oi + oi_incr + } + } else if (dtype == TY_SHORT) { + do j = 1, irows { + oj = oj_start + do i = 1, icols { + call tbegts (itp, icp[i], j, sbuf) + call tbepts (otp, ocp[oi], oj, sbuf) + oj = oj + oj_incr + } + oi = oi + oi_incr + } + } else if (dtype == TY_BOOL) { + do j = 1, irows { + oj = oj_start + do i = 1, icols { + call tbegtb (itp, icp[i], j, bbuf) + call tbeptb (otp, ocp[oi], oj, bbuf) + oj = oj + oj_incr + } + oi = oi + oi_incr + } + } else if (dtype < 0) { + call salloc (cbuf, SZ_LINE, TY_CHAR) + do j = 1, irows { + oj = oj_start + do i = 1, icols { + call tbegtt (itp, icp[i], j, Memc[cbuf], SZ_LINE) + call tbeptt (otp, ocp[oi], oj, Memc[cbuf]) + oj = oj + oj_incr + } + oi = oi + oi_incr + } + } else { + call error (1, "invalid data type") + } + + } else { # each entry is an array + + if (dtype > 0) + call salloc (buf, nelem, dtype) + + if (dtype == TY_REAL) { + do j = 1, irows { + oj = oj_start + do i = 1, icols { + nret = tbagtr (itp, icp[i], j, Memr[buf], 1, nelem) + call tbaptr (otp, ocp[oi], oj, Memr[buf], 1, nret) + oj = oj + oj_incr + } + oi = oi + oi_incr + } + } else if (dtype == TY_DOUBLE) { + do j = 1, irows { + oj = oj_start + do i = 1, icols { + nret = tbagtd (itp, icp[i], j, Memd[buf], 1, nelem) + call tbaptd (otp, ocp[oi], oj, Memd[buf], 1, nret) + oj = oj + oj_incr + } + oi = oi + oi_incr + } + } else if (dtype == TY_INT) { + do j = 1, irows { + oj = oj_start + do i = 1, icols { + nret = tbagti (itp, icp[i], j, Memi[buf], 1, nelem) + call tbapti (otp, ocp[oi], oj, Memi[buf], 1, nret) + oj = oj + oj_incr + } + oi = oi + oi_incr + } + } else if (dtype == TY_SHORT) { + do j = 1, irows { + oj = oj_start + do i = 1, icols { + nret = tbagts (itp, icp[i], j, Mems[buf], 1, nelem) + call tbapts (otp, ocp[oi], oj, Mems[buf], 1, nret) + oj = oj + oj_incr + } + oi = oi + oi_incr + } + } else if (dtype == TY_BOOL) { + do j = 1, irows { + oj = oj_start + do i = 1, icols { + nret = tbagtb (itp, icp[i], j, Memb[buf], 1, nelem) + call tbaptb (otp, ocp[oi], oj, Memb[buf], 1, nret) + oj = oj + oj_incr + } + oi = oi + oi_incr + } + } else if (dtype < 0) { + call salloc (buf, (clen+1) * nelem, TY_CHAR) # add 1 for EOS + do j = 1, irows { + oj = oj_start + do i = 1, icols { + nret = tbagtt (itp, icp[i], j, Memc[buf], clen, + 1, nelem) + call tbaptt (otp, ocp[oi], oj, Memc[buf], clen, 1, nret) + oj = oj + oj_incr + } + oi = oi + oi_incr + } + } else { + call error (1, "invalid data type") + } + } + + call sfree (sp) +end + +# ttr_flip -- copy data from input to output +# This routine copies a table without transposing. +# irows and icols are the numbers of rows and columns in both the +# input and output tables. +# Note that if we are reversing the order of the columns (horizontal flip), +# the last column of the input table was defined first, so the flip in +# column order is taken care of by the relative order of the elements of +# the arrays icp and ocp. + +procedure ttr_flip (itp, otp, icp, ocp, irows, icols, op) + +pointer itp # i: pointer to input table struct +pointer otp # i: pointer to output table struct +pointer icp[icols] # i: array of pointers to input column descriptors +pointer ocp[ARB] # i: array of pointers to output column descriptors +int irows # i: number of rows in input table +int icols # i: number of columns in input table +int op[2] # i: mapping of (columns,rows) from input to output +#-- +int j # loop index for input row number +int oj, oj_incr # loop index and increment for output row number +errchk tbrcpy, tbrcsc + +begin + # Assign values for the beginning and increment for the loop + # on output row number. + if (op[2] > 0) { + oj = 1 + oj_incr = 1 + } else { + oj = irows + oj_incr = -1 + } + + # Copy the data from input to output. + if (op[1] > 0) { + + # Retain column order. + do j = 1, irows { + call tbrcpy (itp, otp, j, oj) + oj = oj + oj_incr + } + + } else { # op[1] < 0 + + # Reverse column order. + do j = 1, irows { + call tbrcsc (itp, otp, icp, ocp, j, oj, icols) + oj = oj + oj_incr + } + } +end diff --git a/pkg/utilities/nttools/tunits.par b/pkg/utilities/nttools/tunits.par new file mode 100644 index 00000000..3d112987 --- /dev/null +++ b/pkg/utilities/nttools/tunits.par @@ -0,0 +1,8 @@ +table,f,a,,,,"Table name" +column,s,a,,,,"Column name" +newunits,s,a,,,,"New column units" +oldunits,s,h," ",,,"Old column units" +abrevtab,f,h,"ttools$tunits/abrev.tab",,,"Table of unit abbreviations" +unittab,f,h,"ttools$tunits/units.tab",,,"Table of unit conversions" +verbose,b,h,no,,,"Print diagnostic messages?" +mode,s,h,al diff --git a/pkg/utilities/nttools/tunits/abrev.tab b/pkg/utilities/nttools/tunits/abrev.tab new file mode 100644 index 00000000..90b8b58c --- /dev/null +++ b/pkg/utilities/nttools/tunits/abrev.tab @@ -0,0 +1,62 @@ +# Abbreviation table for tunits task +# +# Many units have more than one name or abbreviation. This table lists +# the standard abbreviation for each set of units. The abbreviation is +# used internally when computing the conversion factor. Case is not +# significant in names and regular plurals (made by adding an "s") are +# converted to the singular. Names should contain only alphabetic characters. +# Blanks, underscores and digits are not allowed. +# +# name abbreviation +#---------------------------- +meter m +centimeter cm +kilometer km +millimeter mm +micrometer um +micron um +nanometer nm +metre m +centimetre cm +kilometre km +millimetre mm +micrometre um +nanometre nm +kilogram kg +gram g +gm g +milligram mg +second s +sec s +minute min +hour hr +year yr +radian rad +degree deg +arcminute amin +arcmin amin +arcsecond asec +arcsec asec +angstrom a +parsec pc +kiloparsec kpc +megaparsec mpc +hertz hz +kilohertz khz +megahertz mhz +gigahertz ghz +lightyear ly +newton n +joule j +watt w +calorie c +kilocalorie kc +inch in +inches in +foot ft +feet ft +ounce oz +pound lb +liter l +jansky jy +millijansky mjy diff --git a/pkg/utilities/nttools/tunits/abrev.x b/pkg/utilities/nttools/tunits/abrev.x new file mode 100644 index 00000000..f40ca944 --- /dev/null +++ b/pkg/utilities/nttools/tunits/abrev.x @@ -0,0 +1,113 @@ +include +include "tunits.h" + +#* HISTORY * +#* B.Simon 07-Jan-99 Original + +# FIND_ABREV -- Find the abbreviation for a units string + +int procedure find_abrev (ab, units, abrev, maxch) + +pointer ab # i: abbreviation hash table descriptor +char units[ARB] # i: units string +char abrev[ARB] # o: abbreviation string +int maxch # i: maximum length of abbreviation string +#-- +int status +pointer ptr + +int get_unhash() + +begin + status = get_unhash (ab, units, ptr) + if (status == NO) { + abrev[1] = EOS + } else { + call strcpy (Memc[ptr], abrev, maxch) + } + + return (status) +end + +# FREE_ABREV -- Free the abbreviation hash table + +procedure free_abrev (ab) + +pointer ab # i: abbreviation hash table descriptor +#-- +int index +pointer sp, keyword, value + +int each_unhash() + +begin + call smark (sp) + call salloc (keyword, LEN_UNIT, TY_CHAR) + + index = 0 + while (each_unhash (ab, index, Memc[keyword], + value, LEN_UNIT) != EOF) { + if (value != NULL) + call mfree (value, TY_CHAR) + } + + + call free_unhash (ab) + call sfree (sp) +end + +# READ_ABREV -- Read abbreviations from a table and load into a hash + +pointer procedure read_abrev (abrevtab) + +char abrevtab[ARB] # i: abbreviation table name +#-- +int irow, nrow +pointer tp, c1, c2, sp, units, abrev, ab + +string nocolumn "The abbreviation table must have two coulmns" + +int tbpsta() +pointer tbtopn(), tbcnum(), new_unhash() + +begin + # Dynamic memory for strings + + call smark (sp) + call salloc (units, LEN_UNIT, TY_CHAR) + + # Refer to columns numerically because + # this is supposed to be a text file + + tp = tbtopn (abrevtab, READ_ONLY, NULL) + c1 = tbcnum (tp, 1) + c2 = tbcnum (tp, 2) + + if (c1 == NULL || c2 == NULL) + call tuniterr (nocolumn, abrevtab) + + # Create hash + + nrow = tbpsta (tp, TBL_NROWS) + ab = new_unhash (nrow, LEN_UNIT) + + # Read each row into hash + + do irow = 1, nrow { + call malloc (abrev, LEN_UNIT, TY_CHAR) + + call tbegtt (tp, c1, irow, Memc[units], LEN_UNIT) + call tbegtt (tp, c2, irow, Memc[abrev], LEN_UNIT) + + call strlwr (Memc[units]) + call strlwr (Memc[abrev]) + + call add_unhash (ab, Memc[units], abrev) + } + + # Close table and free memory + + call tbtclo (tp) + call sfree (sp) + return (ab) +end diff --git a/pkg/utilities/nttools/tunits/convertcol.x b/pkg/utilities/nttools/tunits/convertcol.x new file mode 100644 index 00000000..976ea888 --- /dev/null +++ b/pkg/utilities/nttools/tunits/convertcol.x @@ -0,0 +1,68 @@ +include + +#* HISTORY * +#* B.Simon 07-Jan-99 Original + +# CONVERT_COL -- Convert the units of a table column + +procedure convert_col (tp, cp, newunits, factor) + +pointer tp # i: table descriptor +pointer cp # i: column descriptor +char newunits[ARB] # i: new column units +double factor # i: conversion factor +#-- +double value +int nrow, nelem, irow, nlen, ilen +pointer sp, buffer + +int tbpsta(), tbcigi(), tbagtd() + +begin + # Change column units + + call tbcnit (tp, cp, newunits) + + # Get column dimensions + + nrow = tbpsta (tp, TBL_NROWS) + nelem = tbcigi (cp, TBL_COL_LENDATA) + + # Allocate buffer to hold array elements + + call smark (sp) + call salloc (buffer, nelem, TY_DOUBLE) + + # Multiply column values by conversion factor + + if (nelem == 1) { + # Scalar column, use element get and put + + do irow = 1, nrow { + call tbegtd (tp, cp, irow, value) + if (! IS_INDEFD (value)) { + value = factor * value + call tbeptd (tp, cp, irow, value) + } + } + + } else { + # Array element, use array get and put + + do irow = 1, nrow { + nlen = tbagtd (tp, cp, irow, Memd[buffer], 1, nelem) + + do ilen = 0, nlen-1 { + if (! IS_INDEFD (Memd[buffer+ilen])) { + Memd[buffer+ilen] = factor * Memd[buffer+ilen] + } + } + + call tbaptd (tp, cp, irow, Memd[buffer], 1, nlen) + } + } + + call sfree (sp) +end + + diff --git a/pkg/utilities/nttools/tunits/factor.x b/pkg/utilities/nttools/tunits/factor.x new file mode 100644 index 00000000..3c9a91ac --- /dev/null +++ b/pkg/utilities/nttools/tunits/factor.x @@ -0,0 +1,125 @@ +include "tunits.h" + +#* HISTORY * +#* B.Simon 07-Jan-99 Original + +# FIND_FACTOR -- Find conversion factor between two sets of units + +double procedure find_factor (ut, punit1, punit2, verbose) + +pointer ut # i: units hash descriptor +pointer punit1 # i: old set of units +pointer punit2 # i: new set of units +bool verbose # i: diagnostic message flag +#-- +double factor +pointer punit3, punit4, punit5 + +string noconvert "The old and new units are not compatible" + +pointer reduce_factor(), div_unstr() + +begin + # Reduce old and new units to a common form + + punit3 = reduce_factor (ut, punit1, verbose) + punit4 = reduce_factor (ut, punit2, verbose) + + # The conversion factor is the ratio of + # the two sets of units when in common form + + punit5 = div_unstr (punit3, punit4) + + # Check to make sure units actually have a common form + + if (TUN_UNPTR(punit5,1) != NULL) + call error (1, noconvert) + + factor = TUN_FACTOR (punit5) + + # Print conversion factor + if (verbose) { + call eprintf ("The conversion factor is %g\n") + call pargd (factor) + } + + # Free temporary units descriptors + + call free_unstr (punit3) + call free_unstr (punit4) + call free_unstr (punit5) + + return (factor) +end + +# REDUCE_FACTOR -- Reduce units descriptor to a common set of units (mks) + +pointer procedure reduce_factor (ut, punit, verbose) + +pointer ut # i: Units hash descriptor +pointer punit # i: Units string descriptor +bool verbose # i: diagnostic message flag +#-- +bool done +int idx +pointer sp, units, punit1, punit2, punit3, punit4 + +int find_units() +pointer copy_unstr(), pow_unstr(), mul_unstr() + +begin + # Allocate memory for units string + + call smark (sp) + call salloc (units, SZ_FNAME, TY_CHAR) + + # Loop until no more reductions can be performed + + punit1 = copy_unstr (punit) + + repeat { + if (verbose) { + call str_unstr (punit1, Memc[units], SZ_FNAME) + call eprintf ("%s") + call pargstr (Memc[units]) + } + + # Search for a reduction for any term + + done = true + do idx = 1, MAXUNIT { + if (TUN_UNPTR(punit1,idx) == NULL) + break + + if (find_units (ut, TUN_UNITS(punit1,idx), punit2) ==YES) { + # Reduction found. Raise conversion factor to + # degree of term in descriptor and then multiply + # the units by it + + punit3 = pow_unstr (punit2, TUN_POWER(punit1,idx)) + punit4 = mul_unstr (punit1, punit3) + + call free_unstr (punit1) + call free_unstr (punit3) + + punit1 = punit4 + done = false + break + } + } + + if (verbose) { + if (done) { + call eprintf ("\n") + } else { + call eprintf (" is \n") + } + } + } until (done) + + if (verbose) + call eprintf ("\n") + + call sfree (sp) + return (punit1) +end diff --git a/pkg/utilities/nttools/tunits/mkpkg b/pkg/utilities/nttools/tunits/mkpkg new file mode 100644 index 00000000..3ec0d98b --- /dev/null +++ b/pkg/utilities/nttools/tunits/mkpkg @@ -0,0 +1,19 @@ +# Update the tunits task in the ttools package library +# Author: Bernie Simon, 11-jan-99 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + abrev.x "tunits.h" + convertcol.x + factor.x "tunits.h" + parseunits.x "parseunits.com" + tuniterr.x + tunits.x "tunits.h" + unhash.x + units.x "tunits.h" + unstr.x "tunits.h" + ; diff --git a/pkg/utilities/nttools/tunits/parseunits.com b/pkg/utilities/nttools/tunits/parseunits.com new file mode 100644 index 00000000..d5c5bf48 --- /dev/null +++ b/pkg/utilities/nttools/tunits/parseunits.com @@ -0,0 +1,9 @@ +# PARSEUNITS.COM -- Global variables used by parse_units + +common / parse / tun, abrev, tokbuf, nxttok, debug + +pointer tun # descriptor containing results of parse +pointer abrev # hash table of unit abbreviations +pointer tokbuf # buffer holding tokens parsed from units string +int nxttok # index to next free space in token buffer +int debug # debugging message flag diff --git a/pkg/utilities/nttools/tunits/parseunits.x b/pkg/utilities/nttools/tunits/parseunits.x new file mode 100644 index 00000000..1a420785 --- /dev/null +++ b/pkg/utilities/nttools/tunits/parseunits.x @@ -0,0 +1,624 @@ +include + +#* B.Simon ?? original +# Phil Hodge 12-Jul-2005 add 'bool yydebug' and 'int get_token()' to +# parse_units + +define YYMAXDEPTH 32 +define YYOPLEN 1 +define yyparse unit_parse + +define SZ_SHORTSTR 31 + +define Y_WRONG 257 +define Y_DONE 258 +define Y_LPAR 259 +define Y_RPAR 260 +define Y_CU 261 +define Y_SQ 262 +define Y_ID 263 +define Y_NUM 264 +define Y_DIV 265 +define Y_MUL 266 +define Y_POW 267 +define yyclearin yychar = -1 +define yyerrok yyerrflag = 0 +define YYMOVE call amovi (Memi[$1], Memi[$2], YYOPLEN) +define YYERRCODE 256 + +# line 159 "parseunits.y" + + +# PARSE_UNITS -- Parse a units string into the internal format + +pointer procedure parse_units (ab, units) + +pointer ab # i: abbreviation hash table +char units[ARB] # i: expression to be parsed +#-- +include "parseunits.com" + +int len, fd +pointer sp + +string syntax "Syntax error in units" + +bool yydebug +int strlen(), stropen(), yyparse() +int get_token() +extern get_token + +begin + len = strlen (units) + 1 + fd = stropen (units, len, READ_ONLY) + + call smark (sp) + call salloc (tokbuf, SZ_FNAME, TY_CHAR) + + debug = NO + yydebug = (debug == YES) + nxttok = 0 + abrev = ab + tun = NULL + + if (yyparse (fd, yydebug, get_token) == ERR) + call tuniterr (syntax, units) + + call close (fd) + call sfree (sp) + return (tun) +end + +# GET_TOKEN -- Retrieve next token from units string + +int procedure get_token (fd, value) + +int fd # i: File containing expression to be lexed +pointer value # o: Address on parse stack to store token +#-- +include "parseunits.com" + +char ch +int type, index, powers[4] +pointer sp, typename, token + +string pownames "sq,square,cu,cubic" +data powers / Y_SQ, Y_SQ, Y_CU, Y_CU / + +bool streq() +int getc(), word_match() + +begin + call smark (sp) + call salloc (typename, SZ_FNAME, TY_CHAR) + + token = tokbuf + nxttok + Memi[value] = token + + repeat { + ch = getc (fd, ch) + } until (ch != ' ' && ch != '\t') + + if (ch == EOF) { + type = Y_DONE + call strcpy ("END", Memc[typename], SZ_FNAME) + + } else if (IS_ALPHA (ch)) { + type = Y_ID + call strcpy ("IDENT", Memc[typename], SZ_FNAME) + + while (IS_ALPHA (ch)) { + Memc[tokbuf+nxttok] = ch + nxttok = nxttok + 1 + ch = getc (fd, ch) + } + call ungetc (fd, ch) + + Memc[tokbuf+nxttok] = EOS + index = word_match (Memc[token], pownames) + + if (index > 0) { + type = powers[index] + call strcpy ("POWER", Memc[typename], SZ_FNAME) + + } else if (streq (Memc[token], "per")) { + type = Y_DIV + call strcpy ("DIV", Memc[typename], SZ_FNAME) + } + + } else if (ch == '-' || IS_DIGIT (ch)) { + type = Y_NUM + call strcpy ("NUMBER", Memc[typename], SZ_FNAME) + + Memc[tokbuf+nxttok] = ch + nxttok = nxttok + 1 + ch = getc (fd, ch) + + while (IS_DIGIT (ch)) { + Memc[tokbuf+nxttok] = ch + nxttok = nxttok + 1 + ch = getc (fd, ch) + } + call ungetc (fd, ch) + + } else { + Memc[tokbuf+nxttok] = ch + nxttok = nxttok + 1 + + switch (ch) { + case '*': + ch = getc (fd, ch) + if (ch == '*') { + type = Y_POW + call strcpy ("EXPON", Memc[typename], SZ_FNAME) + + Memc[tokbuf+nxttok] = ch + nxttok = nxttok + 1 + } else { + type = Y_MUL + call strcpy ("MUL", Memc[typename], SZ_FNAME) + + call ungetc (fd, ch) + } + + case '/': + type = Y_DIV + call strcpy ("DIV", Memc[typename], SZ_FNAME) + + case '^': + type = Y_POW + call strcpy ("EXPON", Memc[typename], SZ_FNAME) + + default: + type = Y_WRONG + call strcpy ("ERROR", Memc[typename], SZ_FNAME) + } + } + + Memc[tokbuf+nxttok] = EOS + nxttok = nxttok + 1 + + if (debug == YES) { + call eprintf ("Token is %s [%s]\n") + if (Memc[token] == EOS) { + call pargstr ("EOS") + } else { + call pargstr (Memc[token]) + } + call pargstr (Memc[typename]) + } + + call sfree (sp) + return (type) +end +define YYNPROD 15 +define YYLAST 43 +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Parser for yacc output, translated to the IRAF SPP language. The contents +# of this file form the bulk of the source of the parser produced by Yacc. +# Yacc recognizes several macros in the yaccpar input source and replaces +# them as follows: +# A user suppled "global" definitions and declarations +# B parser tables +# C user supplied actions (reductions) +# The remainder of the yaccpar code is not changed. + +define yystack_ 10 # statement labels for gotos +define yynewstate_ 20 +define yydefault_ 30 +define yyerrlab_ 40 +define yyabort_ 50 + +define YYFLAG (-1000) # defs used in user actions +define YYERROR goto yyerrlab_ +define YYACCEPT return (OK) +define YYABORT return (ERR) + + +# YYPARSE -- Parse the input stream, returning OK if the source is +# syntactically acceptable (i.e., if compilation is successful), +# otherwise ERR. The parameters YYMAXDEPTH and YYOPLEN must be +# supplied by the caller in the %{ ... %} section of the Yacc source. +# The token value stack is a dynamically allocated array of operand +# structures, with the length and makeup of the operand structure being +# application dependent. + +int procedure yyparse (fd, yydebug, yylex) + +int fd # stream to be parsed +bool yydebug # print debugging information? +int yylex() # user-supplied lexical input function +extern yylex() + +short yys[YYMAXDEPTH] # parser stack -- stacks tokens +pointer yyv # pointer to token value stack +pointer yyval # value returned by action +pointer yylval # value of token +int yyps # token stack pointer +pointer yypv # value stack pointer +int yychar # current input token number +int yyerrflag # error recovery flag +int yynerrs # number of errors + +short yyj, yym # internal variables +pointer yysp, yypvt +short yystate, yyn +int yyxi, i +errchk salloc, yylex + + +include "parseunits.com" + +char units[SZ_FNAME] + +int num_unstr() +pointer mul_unstr(), div_unstr(), pow_unstr(), set_unstr() + +short yyexca[6] +data (yyexca(i),i= 1, 6) / -1, 1, 0, -1, -2, 0/ +short yyact[43] +data (yyact(i),i= 1, 8) / 23, 10, 11, 13, 13, 12, 11, 13/ +data (yyact(i),i= 9, 16) / 12, 11, 13, 17, 3, 24, 16, 4/ +data (yyact(i),i= 17, 24) / 22, 8, 9, 7, 4, 19, 8, 9/ +data (yyact(i),i= 25, 32) / 7, 8, 9, 7, 18, 2, 6, 5/ +data (yyact(i),i= 33, 40) / 1, 0, 14, 0, 15, 0, 0, 0/ +data (yyact(i),i= 41, 43) / 0, 20, 21/ +short yypact[25] +data (yypact(i),i= 1, 8) /-244,-1000,-257,-1000,-239,-236,-1000,-253/ +data (yypact(i),i= 9, 16) /-235,-242,-1000,-239,-239,-248,-260,-1000/ +data (yypact(i),i= 17, 24) /-251,-1000,-1000,-1000,-263,-264,-1000,-1000/ +data (yypact(i),i= 25, 25) /-1000/ +short yypgo[5] +data (yypgo(i),i= 1, 5) / 0, 32, 29, 31, 30/ +short yyr1[15] +data (yyr1(i),i= 1, 8) / 0, 1, 1, 2, 2, 2, 2, 2/ +data (yyr1(i),i= 9, 15) / 3, 3, 4, 4, 4, 4, 4/ +short yyr2[15] +data (yyr2(i),i= 1, 8) / 0, 2, 1, 3, 3, 3, 3, 1/ +data (yyr2(i),i= 9, 15) / 2, 1, 3, 2, 2, 2, 1/ +short yychk[25] +data (yychk(i),i= 1, 8) /-1000, -1, -2, 256, 259, -3, -4, 263/ +data (yychk(i),i= 9, 16) / 261, 262, 258, 266, 265, 267, -2, -4/ +data (yychk(i),i= 17, 24) / 267, 264, 263, 263, -2, -2, 264, 260/ +data (yychk(i),i= 25, 25) / 264/ +short yydef[25] +data (yydef(i),i= 1, 8) / 0, -2, 0, 2, 0, 7, 9, 14/ +data (yydef(i),i= 9, 16) / 0, 0, 1, 0, 0, 0, 0, 8/ +data (yydef(i),i= 17, 24) / 0, 11, 12, 13, 4, 5, 6, 3/ +data (yydef(i),i= 25, 25) / 10/ + +begin + call smark (yysp) + call salloc (yyv, (YYMAXDEPTH+2) * YYOPLEN, TY_STRUCT) + + # Initialization. The first element of the dynamically allocated + # token value stack (yyv) is used for yyval, the second for yylval, + # and the actual stack starts with the third element. + + yystate = 0 + yychar = -1 + yynerrs = 0 + yyerrflag = 0 + yyps = 0 + yyval = yyv + yylval = yyv + YYOPLEN + yypv = yylval + +yystack_ + # SHIFT -- Put a state and value onto the stack. The token and + # value stacks are logically the same stack, implemented as two + # separate arrays. + + if (yydebug) { + call printf ("state %d, char 0%o\n") + call pargs (yystate) + call pargi (yychar) + } + yyps = yyps + 1 + yypv = yypv + YYOPLEN + if (yyps > YYMAXDEPTH) { + call sfree (yysp) + call eprintf ("yacc stack overflow\n") + return (ERR) + } + yys[yyps] = yystate + YYMOVE (yyval, yypv) + +yynewstate_ + # Process the new state. + yyn = yypact[yystate+1] + + if (yyn <= YYFLAG) + goto yydefault_ # simple state + + # The variable "yychar" is the lookahead token. + if (yychar < 0) { + yychar = yylex (fd, yylval) + if (yychar < 0) + yychar = 0 + } + yyn = yyn + yychar + if (yyn < 0 || yyn >= YYLAST) + goto yydefault_ + + yyn = yyact[yyn+1] + if (yychk[yyn+1] == yychar) { # valid shift + yychar = -1 + YYMOVE (yylval, yyval) + yystate = yyn + if (yyerrflag > 0) + yyerrflag = yyerrflag - 1 + goto yystack_ + } + +yydefault_ + # Default state action. + + yyn = yydef[yystate+1] + if (yyn == -2) { + if (yychar < 0) { + yychar = yylex (fd, yylval) + if (yychar < 0) + yychar = 0 + } + + # Look through exception table. + yyxi = 1 + while ((yyexca[yyxi] != (-1)) || (yyexca[yyxi+1] != yystate)) + yyxi = yyxi + 2 + for (yyxi=yyxi+2; yyexca[yyxi] >= 0; yyxi=yyxi+2) { + if (yyexca[yyxi] == yychar) + break + } + + yyn = yyexca[yyxi+1] + if (yyn < 0) { + call sfree (yysp) + return (OK) # ACCEPT -- all done + } + } + + + # SYNTAX ERROR -- resume parsing if possible. + + if (yyn == 0) { + switch (yyerrflag) { + case 0, 1, 2: + if (yyerrflag == 0) { # brand new error + call eprintf ("syntax error\n") +yyerrlab_ + yynerrs = yynerrs + 1 + # fall through... + } + + # case 1: + # case 2: incompletely recovered error ... try again + yyerrflag = 3 + + # Find a state where "error" is a legal shift action. + while (yyps >= 1) { + yyn = yypact[yys[yyps]+1] + YYERRCODE + if ((yyn >= 0) && (yyn < YYLAST) && + (yychk[yyact[yyn+1]+1] == YYERRCODE)) { + # Simulate a shift of "error". + yystate = yyact[yyn+1] + goto yystack_ + } + yyn = yypact[yys[yyps]+1] + + # The current yyps has no shift on "error", pop stack. + if (yydebug) { + call printf ("error recovery pops state %d, ") + call pargs (yys[yyps]) + call printf ("uncovers %d\n") + call pargs (yys[yyps-1]) + } + yyps = yyps - 1 + yypv = yypv - YYOPLEN + } + + # ABORT -- There is no state on the stack with an error shift. +yyabort_ + call sfree (yysp) + return (ERR) + + + case 3: # No shift yet; clobber input char. + + if (yydebug) { + call printf ("error recovery discards char %d\n") + call pargi (yychar) + } + + if (yychar == 0) + goto yyabort_ # don't discard EOF, quit + yychar = -1 + goto yynewstate_ # try again in the same state + } + } + + + # REDUCE -- Reduction by production yyn. + + if (yydebug) { + call printf ("reduce %d\n") + call pargs (yyn) + } + yyps = yyps - yyr2[yyn+1] + yypvt = yypv + yypv = yypv - yyr2[yyn+1] * YYOPLEN + YYMOVE (yypv + YYOPLEN, yyval) + yym = yyn + + # Consult goto table to find next state. + yyn = yyr1[yyn+1] + yyj = yypgo[yyn+1] + yys[yyps] + 1 + if (yyj >= YYLAST) + yystate = yyact[yypgo[yyn+1]+1] + else { + yystate = yyact[yyj+1] + if (yychk[yystate+1] != -yyn) + yystate = yyact[yypgo[yyn+1]+1] + } + + # Perform action associated with the grammar rule, if any. + switch (yym) { + +case 1: +# line 28 "parseunits.y" +{ + # Normal exit. Return pointer to units structure + if (debug == YES) + call eprintf ("\n") + + tun = Memi[yypvt-YYOPLEN] + return (OK) + } +case 2: +# line 36 "parseunits.y" +{ + # Syntax error + if (debug == YES) + call eprintf ("\n") + + return (ERR) + } +case 3: +# line 45 "parseunits.y" +{ + # Parenthesized expression + Memi[yyval] = Memi[yypvt-2*YYOPLEN] + } +case 4: +# line 49 "parseunits.y" +{ + # Multiply two units expressions + Memi[yyval] = mul_unstr (Memi[yypvt-2*YYOPLEN], Memi[yypvt]) + call free_unstr (Memi[yypvt-2*YYOPLEN]) + call free_unstr (Memi[yypvt]) + + if (debug == YES) { + call str_unstr (Memi[yyval], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } +case 5: +# line 61 "parseunits.y" +{ + # Divide two units expressions + Memi[yyval] = div_unstr (Memi[yypvt-2*YYOPLEN], Memi[yypvt]) + call free_unstr (Memi[yypvt-2*YYOPLEN]) + call free_unstr (Memi[yypvt]) + + if (debug == YES) { + call str_unstr (Memi[yyval], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } +case 6: +# line 73 "parseunits.y" +{ + # Raise expression to a power + Memi[yyval] = pow_unstr (Memi[yypvt-2*YYOPLEN], num_unstr (Memc[Memi[yypvt]])) + call free_unstr (Memi[yypvt-2*YYOPLEN]) + + if (debug == YES) { + call str_unstr (Memi[yyval], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } +case 7: +# line 84 "parseunits.y" +{ + # List of terms + Memi[yyval] = Memi[yypvt] + } +case 8: +# line 89 "parseunits.y" +{ + # Implicit multiplication + Memi[yyval] = mul_unstr (Memi[yypvt-YYOPLEN], Memi[yypvt]) + call free_unstr (Memi[yypvt-YYOPLEN]) + call free_unstr (Memi[yypvt]) + + if (debug == YES) { + call str_unstr (Memi[yyval], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } +case 9: +# line 101 "parseunits.y" +{ + # Simple term + Memi[yyval] = Memi[yypvt] + } +case 10: +# line 106 "parseunits.y" +{ + # Raise units to a power + Memi[yyval] = set_unstr (abrev, Memc[Memi[yypvt-2*YYOPLEN]], + num_unstr (Memc[Memi[yypvt]])) + + if (debug == YES) { + call str_unstr (Memi[yyval], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } +case 11: +# line 117 "parseunits.y" +{ + # Implicitly raise to a power + Memi[yyval] = set_unstr (abrev, Memc[Memi[yypvt-YYOPLEN]], + num_unstr (Memc[Memi[yypvt]])) + + if (debug == YES) { + call str_unstr (Memi[yyval], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } +case 12: +# line 128 "parseunits.y" +{ + # Cubic prefix + Memi[yyval] = set_unstr (abrev, Memc[Memi[yypvt]], 3) + + if (debug == YES) { + call str_unstr (Memi[yyval], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } +case 13: +# line 138 "parseunits.y" +{ + # Square prefix + Memi[yyval] = set_unstr (abrev, Memc[Memi[yypvt]], 2) + + if (debug == YES) { + call str_unstr (Memi[yyval], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } +case 14: +# line 148 "parseunits.y" +{ + # Simple name + Memi[yyval] = set_unstr (abrev, Memc[Memi[yypvt]], 1) + + if (debug == YES) { + call str_unstr (Memi[yyval], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } } + + goto yystack_ # stack new state and value +end diff --git a/pkg/utilities/nttools/tunits/parseunits.y b/pkg/utilities/nttools/tunits/parseunits.y new file mode 100644 index 00000000..088395ac --- /dev/null +++ b/pkg/utilities/nttools/tunits/parseunits.y @@ -0,0 +1,322 @@ +%{ +include + +define YYMAXDEPTH 32 +define YYOPLEN 1 +define yyparse unit_parse + +define SZ_SHORTSTR 31 + +%L +include "parseunits.com" + +char units[SZ_FNAME] + +int num_unstr() +pointer mul_unstr(), div_unstr(), pow_unstr(), set_unstr() + +%} + +%token Y_WRONG Y_DONE Y_LPAR Y_RPAR Y_CU Y_SQ Y_ID Y_NUM + +%left Y_DIV +%left Y_MUL +%right Y_POW + +%% + +unit : expr Y_DONE { + # Normal exit. Return pointer to units structure + if (debug == YES) + call eprintf ("\n") + + tun = Memi[$1] + return (OK) + } + | error { + # Syntax error + if (debug == YES) + call eprintf ("\n") + + return (ERR) + } + ; + +expr : Y_LPAR expr Y_RPAR { + # Parenthesized expression + Memi[$$] = Memi[$1] + } + | expr Y_MUL expr { + # Multiply two units expressions + Memi[$$] = mul_unstr (Memi[$1], Memi[$3]) + call free_unstr (Memi[$1]) + call free_unstr (Memi[$3]) + + if (debug == YES) { + call str_unstr (Memi[$$], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } + | expr Y_DIV expr { + # Divide two units expressions + Memi[$$] = div_unstr (Memi[$1], Memi[$3]) + call free_unstr (Memi[$1]) + call free_unstr (Memi[$3]) + + if (debug == YES) { + call str_unstr (Memi[$$], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } + | expr Y_POW Y_NUM { + # Raise expression to a power + Memi[$$] = pow_unstr (Memi[$1], num_unstr (Memc[Memi[$3]])) + call free_unstr (Memi[$1]) + + if (debug == YES) { + call str_unstr (Memi[$$], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } + | termlist { + # List of terms + Memi[$$] = Memi[$1] + } + ; +termlist: termlist term { + # Implicit multiplication + Memi[$$] = mul_unstr (Memi[$1], Memi[$2]) + call free_unstr (Memi[$1]) + call free_unstr (Memi[$2]) + + if (debug == YES) { + call str_unstr (Memi[$$], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } + | term { + # Simple term + Memi[$$] = Memi[$1] + } + ; +term : Y_ID Y_POW Y_NUM { + # Raise units to a power + Memi[$$] = set_unstr (abrev, Memc[Memi[$1]], + num_unstr (Memc[Memi[$3]])) + + if (debug == YES) { + call str_unstr (Memi[$$], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } + | Y_ID Y_NUM { + # Implicitly raise to a power + Memi[$$] = set_unstr (abrev, Memc[Memi[$1]], + num_unstr (Memc[Memi[$2]])) + + if (debug == YES) { + call str_unstr (Memi[$$], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } + | Y_CU Y_ID { + # Cubic prefix + Memi[$$] = set_unstr (abrev, Memc[Memi[$2]], 3) + + if (debug == YES) { + call str_unstr (Memi[$$], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } + | Y_SQ Y_ID { + # Square prefix + Memi[$$] = set_unstr (abrev, Memc[Memi[$2]], 2) + + if (debug == YES) { + call str_unstr (Memi[$$], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } + | Y_ID { + # Simple name + Memi[$$] = set_unstr (abrev, Memc[Memi[$1]], 1) + + if (debug == YES) { + call str_unstr (Memi[$$], units, SZ_FNAME) + call eprintf ("Units are %s\n") + call pargstr (units) + } + } + ; +%% + +# PARSE_UNITS -- Parse a units string into the internal format + +pointer procedure parse_units (ab, units) + +pointer ab # i: abbreviation hash table +char units[ARB] # i: expression to be parsed +#-- +include "parseunits.com" + +int len, fd +pointer sp + +string syntax "Syntax error in units" + +bool yydebug +int strlen(), stropen(), yyparse() +int get_token() +extern get_token + +begin + len = strlen (units) + 1 + fd = stropen (units, len, READ_ONLY) + + call smark (sp) + call salloc (tokbuf, SZ_FNAME, TY_CHAR) + + debug = NO + yydebug = (debug == YES) + nxttok = 0 + abrev = ab + tun = NULL + + if (yyparse (fd, yydebug, get_token) == ERR) + call tuniterr (syntax, units) + + call close (fd) + call sfree (sp) + return (tun) +end + +# GET_TOKEN -- Retrieve next token from units string + +int procedure get_token (fd, value) + +int fd # i: File containing expression to be lexed +pointer value # o: Address on parse stack to store token +#-- +include "parseunits.com" + +char ch +int type, index, powers[4] +pointer sp, typename, token + +string pownames "sq,square,cu,cubic" +data powers / Y_SQ, Y_SQ, Y_CU, Y_CU / + +bool streq() +int getc(), word_match() + +begin + call smark (sp) + call salloc (typename, SZ_FNAME, TY_CHAR) + + token = tokbuf + nxttok + Memi[value] = token + + repeat { + ch = getc (fd, ch) + } until (ch != ' ' && ch != '\t') + + if (ch == EOF) { + type = Y_DONE + call strcpy ("END", Memc[typename], SZ_FNAME) + + } else if (IS_ALPHA (ch)) { + type = Y_ID + call strcpy ("IDENT", Memc[typename], SZ_FNAME) + + while (IS_ALPHA (ch)) { + Memc[tokbuf+nxttok] = ch + nxttok = nxttok + 1 + ch = getc (fd, ch) + } + call ungetc (fd, ch) + + Memc[tokbuf+nxttok] = EOS + index = word_match (Memc[token], pownames) + + if (index > 0) { + type = powers[index] + call strcpy ("POWER", Memc[typename], SZ_FNAME) + + } else if (streq (Memc[token], "per")) { + type = Y_DIV + call strcpy ("DIV", Memc[typename], SZ_FNAME) + } + + } else if (ch == '-' || IS_DIGIT (ch)) { + type = Y_NUM + call strcpy ("NUMBER", Memc[typename], SZ_FNAME) + + Memc[tokbuf+nxttok] = ch + nxttok = nxttok + 1 + ch = getc (fd, ch) + + while (IS_DIGIT (ch)) { + Memc[tokbuf+nxttok] = ch + nxttok = nxttok + 1 + ch = getc (fd, ch) + } + call ungetc (fd, ch) + + } else { + Memc[tokbuf+nxttok] = ch + nxttok = nxttok + 1 + + switch (ch) { + case '*': + ch = getc (fd, ch) + if (ch == '*') { + type = Y_POW + call strcpy ("EXPON", Memc[typename], SZ_FNAME) + + Memc[tokbuf+nxttok] = ch + nxttok = nxttok + 1 + } else { + type = Y_MUL + call strcpy ("MUL", Memc[typename], SZ_FNAME) + + call ungetc (fd, ch) + } + + case '/': + type = Y_DIV + call strcpy ("DIV", Memc[typename], SZ_FNAME) + + case '^': + type = Y_POW + call strcpy ("EXPON", Memc[typename], SZ_FNAME) + + default: + type = Y_WRONG + call strcpy ("ERROR", Memc[typename], SZ_FNAME) + } + } + + Memc[tokbuf+nxttok] = EOS + nxttok = nxttok + 1 + + if (debug == YES) { + call eprintf ("Token is %s [%s]\n") + if (Memc[token] == EOS) { + call pargstr ("EOS") + } else { + call pargstr (Memc[token]) + } + call pargstr (Memc[typename]) + } + + call sfree (sp) + return (type) +end diff --git a/pkg/utilities/nttools/tunits/tuniterr.x b/pkg/utilities/nttools/tunits/tuniterr.x new file mode 100644 index 00000000..25a750c5 --- /dev/null +++ b/pkg/utilities/nttools/tunits/tuniterr.x @@ -0,0 +1,24 @@ +#* HISTORY * +#* B.Simon 07-Jan-99 Original + +# TUNITERR -- Print error message for tunits + +procedure tuniterr (errstr, errval) + +char errstr[ARB] # i: error message string +char errval[ARB] # i: value which caused error +#-- +pointer sp, errmsg + +begin + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + call sprintf (Memc[errmsg], SZ_LINE, "%s (%s)") + call pargstr (errstr) + call pargstr (errval) + + call error (1, Memc[errmsg]) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tunits/tunits.h b/pkg/utilities/nttools/tunits/tunits.h new file mode 100644 index 00000000..f5c2162a --- /dev/null +++ b/pkg/utilities/nttools/tunits/tunits.h @@ -0,0 +1,14 @@ +# TUNITS.H -- Structure and constants used by tunits + +define MAXUNIT 8 +define LEN_UNIT 15 + +define LEN_TUNSTRUCT (SZ_DOUBLE+2*MAXUNIT) + +define TUN_FACTOR Memd[P2D($1)] # conversion factor +define TUN_UNPTR Memi[$1+SZ_DOUBLE+$2] # ptr to units string +define TUN_POWER Memi[$1+SZ_DOUBLE+MAXUNIT+$2] # units power + +define TUN_UNITS Memc[TUN_UNPTR($1,$2)] # units string + +define FINALS "m,kg,s,rad,hz" diff --git a/pkg/utilities/nttools/tunits/tunits.x b/pkg/utilities/nttools/tunits/tunits.x new file mode 100644 index 00000000..526bca11 --- /dev/null +++ b/pkg/utilities/nttools/tunits/tunits.x @@ -0,0 +1,112 @@ +include +include "tunits.h" + +#* HISTORY * +#* B.Simon 07-Jan-99 Original + +# TUNITS -- Convert table column from one set of units to another + +procedure tunits () + +#-- +pointer table # table name +pointer column # column name +pointer newunits # new column units +pointer oldunits # old column units +pointer abrevtab # table of unit abbreviations +pointer unittab # table of unit conversions +bool verbose # print diagnostic messages + +double factor +int type +pointer sp, tp, cp, ab, ut, punit1, punit2 + +string nocolumn "Column not found" +string unitblank "Units parameter is blank" +string notfloat "Table column is not floating point" + +bool clgetb(), isblank() +double find_factor() +int tbcigi() +pointer tbtopn(), read_abrev(), read_units(), parse_units() + +begin + # Allocate memory for temporary strings + + call smark (sp) + call salloc (table, SZ_FNAME, TY_CHAR) + call salloc (column, SZ_FNAME, TY_CHAR) + call salloc (newunits, SZ_FNAME, TY_CHAR) + call salloc (oldunits, SZ_FNAME, TY_CHAR) + call salloc (abrevtab, SZ_FNAME, TY_CHAR) + call salloc (unittab, SZ_FNAME, TY_CHAR) + + # Read required task parameters + + call clgstr ("table", Memc[table], SZ_FNAME) + call clgstr ("column", Memc[column], SZ_FNAME) + call clgstr ("newunits", Memc[newunits], SZ_FNAME) + call clgstr ("oldunits", Memc[oldunits], SZ_FNAME) + call clgstr ("abrevtab", Memc[abrevtab], SZ_FNAME) + call clgstr ("unittab", Memc[unittab], SZ_FNAME) + verbose = clgetb ("verbose") + + # Open table, find column + + tp = tbtopn (Memc[table], READ_WRITE, NULL) + call tbcfnd (tp, Memc[column], cp, 1) + if (cp == NULL) + call tuniterr (nocolumn, Memc[column]) + + # Read column units if old units are blank + + if (isblank (Memc[oldunits])) + call tbcigt (cp, TBL_COL_UNITS, Memc[oldunits], SZ_FNAME) + + call strlwr (Memc[oldunits]) + call strlwr (Memc[newunits]) + + # Check to see if units are not blank + + if (isblank (Memc[oldunits])) + call tuniterr (unitblank, "oldunits") + + if (isblank (Memc[newunits])) + call tuniterr (unitblank, "newunits") + + # Check to see if column is floating point + + type = tbcigi (cp, TBL_COL_DATATYPE) + if (type != TY_REAL && type != TY_DOUBLE) + call tuniterr (notfloat, Memc[column]) + + # Read units and abbreviation tables into hashes + + ab = read_abrev (Memc[abrevtab]) + ut = read_units (ab, Memc[unittab]) + + # Convert units to internal form + + punit1 = parse_units (ab, Memc[oldunits]) + punit2 = parse_units (ab, Memc[newunits]) + + # Find conversion factor between units + + factor = find_factor (ut, punit1, punit2, verbose) + + # Apply conversion factor to table column + + call convert_col (tp, cp, Memc[newunits], factor) + + # Close table and free allocated memory + + call tbtclo (tp) + + call free_abrev (ab) + call free_units (ut) + + call free_unstr (punit1) + call free_unstr (punit2) + + call sfree (sp) +end diff --git a/pkg/utilities/nttools/tunits/unhash.x b/pkg/utilities/nttools/tunits/unhash.x new file mode 100644 index 00000000..3ae9c24e --- /dev/null +++ b/pkg/utilities/nttools/tunits/unhash.x @@ -0,0 +1,212 @@ +# A set of procedures that implement a generic hash table. The hash table +# stores the key, plus a pointer to the value structure. It should be +# wrapped in a more specific set of calls that can read the value structure + +define LEN_UNHSTRUCT 5 + +define UNH_SIZE Memi[$1] +define UNH_NEXT Memi[$1+1] +define UNH_KEYBUF Memi[$1+2] +define UNH_VALBUF Memi[$1+3] +define UNH_STRBUF Memi[$1+4] + +define UNH_KEY Memi[UNH_KEYBUF($1)+$2] +define UNH_VALUE Memi[UNH_VALBUF($1)+$2] + +#* HISTORY * +#* B.Simon 07-Jan-99 Original + +# ADD_UNHASH -- Add a new keyword and value to the hash table + +procedure add_unhash (hash, keyword, value) + +pointer hash # i: Descriptor of hash table +char keyword[ARB] # i: Keyword to add to hash table +pointer value # i: Value descriptor +#-- +int index, nc + +string duplicate "Cannot add duplicate keyword to hash table" + +int gstrcpy(), loc_unhash() + +begin + # Find where keyword should be inserted + + index = loc_unhash (hash, keyword) + + # Adding duplicate keywords is not allowed + + if (UNH_KEY(hash,index) != NULL) { + call tuniterr (duplicate, keyword) + + } else { + UNH_KEY(hash,index) = UNH_NEXT(hash) + UNH_VALUE(hash,index) = value + + nc = gstrcpy (keyword, Memc[UNH_NEXT(hash)], ARB) + UNH_NEXT(hash) = UNH_NEXT(hash) + nc + 1 + } +end + +# CALC_UNHASH -- Calculate hash index and step size from keyword + +procedure calc_unhash (hash, keyword, index, step) + +pointer hash # i: Descriptor of hash table +char keyword[ARB] # i: Keyword to search for in hash table +int index # o: Location to place keyword at in hash +int step # o: Step size in case location is filled +#-- +int ic + +begin + # Standard hash table function based on munging characters + + index = 0 + step = 0 + + for (ic = 1; keyword[ic] != EOS; ic = ic + 1) { + index = 2 * index + keyword[ic] + step = step + keyword[ic] + } + + # This line ensures the step size is odd + + step = step - mod (step, 2) + 1 +end + +# EACH_UNHASH -- Retrieve values from hash table serially + +int procedure each_unhash (hash, index, keyword, value, maxch) + +pointer hash # i: Descriptor of hash table +int index # u: Index of next slot in hash table to examine +char keyword[ARB] # o: Keyword name +pointer value # o: Keyword value +int maxch # i: Maximum length of keyword +#-- + +begin + while (index < UNH_SIZE(hash)) { + if (UNH_KEY(hash,index) != NULL) { + call strcpy (Memc[UNH_KEY(hash,index)], keyword, maxch) + value = UNH_VALUE(hash,index) + index = index + 1 + return (OK) + } + + index = index + 1 + } + + return (EOF) +end + +# FREE_UNHASH -- Free a hash table + +procedure free_unhash (hash) + +pointer hash # i: hash table descriptor +#-- + +begin + # This code assumes that all memory associated + # with the values has already been freed + + call mfree (UNH_STRBUF(hash), TY_CHAR) + call mfree (UNH_VALBUF(hash), TY_INT) + call mfree (UNH_KEYBUF(hash), TY_INT) + call mfree (hash, TY_INT) +end + +# GET_UNHASH -- Return a keyword's value from a hash + +int procedure get_unhash (hash, keyword, value) + +pointer hash # i: Descriptor of hash table +char keyword[ARB] # i: Keyword to add to hash table +pointer value # o: pointer to hash table value +#-- +int index, status + +int loc_unhash () + +begin + # The keyword is found if its slot is not null + + index = loc_unhash (hash, keyword) + + if (UNH_KEY(hash,index) == NULL) { + value = NULL + status = NO + } else { + value = UNH_VALUE(hash,index) + status = YES + } + + return (status) +end + +# LOC_UNHASH -- Return index of location where a key should be inserted + +int procedure loc_unhash (hash, keyword) + +pointer hash # i: Descriptor of hash table +char keyword[ARB] # i: Keyword to add to hash table +#-- +int index, step + +bool streq() + +begin + # Calculate initial guess at position in hash table + # and step size in case guessed position is already filled + + call calc_unhash (hash, keyword, index, step) + index = mod (index, UNH_SIZE(hash)) + + # Loop until an empty slot is found or the keyword is matched + + repeat { + if (UNH_KEY(hash,index) == NULL) { + break + + } else if (streq (Memc[UNH_KEY(hash,index)], keyword)) { + break + } + + index = mod (index + step, UNH_SIZE(hash)) + } + + return (index) +end + +# NEW_UNHASH -- Create a new hash table + +pointer procedure new_unhash (nkey, keysize) + +int nkey # i: number of keywords in the hash +int keysize # i: maximum length of a key +#-- +int size +pointer hash + +begin + # Find a power of two greater than the number of keywords + + for (size = 1; size < 2 * nkey; size = 2 * size) + ; + + # Allocate structure for hash and set initial values + + call malloc (hash, LEN_UNHSTRUCT, TY_INT) + call calloc (UNH_KEYBUF(hash), size, TY_INT) + call calloc (UNH_VALBUF(hash), size, TY_INT) + call malloc (UNH_STRBUF(hash), size*(keysize+1), TY_CHAR) + + UNH_SIZE(hash) = size + UNH_NEXT(hash) = UNH_STRBUF(hash) + + return (hash) +end + diff --git a/pkg/utilities/nttools/tunits/units.tab b/pkg/utilities/nttools/tunits/units.tab new file mode 100644 index 00000000..4d2c1f9c --- /dev/null +++ b/pkg/utilities/nttools/tunits/units.tab @@ -0,0 +1,60 @@ +# Conversion factors for tunits task +# +# Read this table as "There are in a ." +# For example, "There are 100 centimeters in a meter." +# The last column, swap, does not change the sense of the sentence +# but does change the direction that the conversion is applied, +# For example, "60 seconds in a minute" is actually a conversion +# from minutes to seconds because swap is yes. Unit conversions +# should set swap to yes when the desired conversion is not an exact +# value, but its inverse is. Only one conversion is allowed per +# unit, which simplifies the program logic considerably. Conversions +# should be chosen so that they ultimately resolve to MKS units. To +# prevent endless loops conversions from the fundamental units are +# checked for and forbidden. However, the program does not check for +# other loops, so be careful when adding new conversions! +# +# factor from to swap? +#---------------------------------------------------- +100 centimeter meter no +1e-3 kilometer meter no +1e3 millimeter meter no +1e6 micron meter no +1e9 nanometer meter no +1e10 angstrom meter no +1e3 gram kilogram no +1e6 milligram kilogram no +60 second minute yes +60 minute hour yes +24 hour day yes +365.2421897 day year yes +57.2957795131 degree radian no +60 arcminute degree no +60 arcsecond arcminute no +1.4959787066e11 meter au yes +206264.806247 au parsec yes +1e3 parsec kiloparsec yes +1e6 parsec megaparsec yes +9.46073047e15 meter lightyear yes +1e3 liter m^3 no +1 newton kg*m/s^2 no +1 joule kg*m^2/s^2 no +1 watt kg*m^2/s^3 no +1 dyne gm*cm/s^2 no +1 erg gm*cm^2/s^2 no +2.54 centimeter inch yes +12 inch foot yes +5280 foot mile yes +16 ounce pound no +0.45359237 pound kilogram no +1054.4 btu joule no +4.184 calorie joule no +1e-3 kilocalorie calorie no +6.24150648e18 ev joule no +1e-3 kev ev no +1e-6 mev ev no +1e23 jansky erg/s*cm^2*hz no +1e3 millijansky jansky no +1e-3 kilohertz hertz no +1e-6 megahertz hertz no +1e-9 gigahertz hertz no diff --git a/pkg/utilities/nttools/tunits/units.x b/pkg/utilities/nttools/tunits/units.x new file mode 100644 index 00000000..6f4374df --- /dev/null +++ b/pkg/utilities/nttools/tunits/units.x @@ -0,0 +1,162 @@ +include +include "tunits.h" + +#* HISTORY * +#* B.Simon 07-Jan-99 Original + +# FIND_UNITS -- Find the conversion factor for a set of units + +int procedure find_units (ut, units, punit) + +pointer ut # i: units hash table descriptor +char units[ARB] # i: units string +pointer punit # o: conversion factor as units structure +#-- +int get_unhash() + +begin + return (get_unhash (ut, units, punit)) +end + +# FREE_UNITS -- Free the abbreviation hash table + +procedure free_units (ut) + +pointer ut # i: units hash table descriptor +#-- +int index +pointer sp, units, punit + +int each_unhash() + +begin + call smark (sp) + call salloc (units, LEN_UNIT, TY_CHAR) + + index = 0 + while (each_unhash (ut, index, Memc[units], + punit, LEN_UNIT) != EOF) { + if (punit != NULL) + call free_unstr (punit) + } + + call free_unhash (ut) + call sfree (sp) +end + +# READ_UNITS -- Read units conversions from a table and load into a hash + +pointer procedure read_units (ab, unittab) + +pointer ab # i: abbreviation table descriptor +char unittab[ARB] # i: units conversion table name +#-- +bool swap, verbose +double factor +int irow, nrow +pointer sp, temp, oldunits, newunits +pointer tp, c1, c2, c3, c4 +pointer ut, punit1, punit2, punit3 + +data verbose / false / + +string nocolumn "The units conversion table must have four columns" +string badfactor "Error in units table: factor must be greater than zero" +string nofinal "Error in units table: conversion from final units not allowed" + +int tbpsta(), word_match() +pointer tbtopn(), tbcnum(), new_unhash() +pointer parse_units(), div_unstr() + +begin + # Dynamic memory for strings + + call smark (sp) + call salloc (temp, SZ_FNAME, TY_CHAR) + call salloc (oldunits, SZ_FNAME, TY_CHAR) + call salloc (newunits, SZ_FNAME, TY_CHAR) + + # Refer to columns numerically because + # this is supposed to be a text file + + tp = tbtopn (unittab, READ_ONLY, NULL) + c1 = tbcnum (tp, 1) + c2 = tbcnum (tp, 2) + c3 = tbcnum (tp, 3) + c4 = tbcnum (tp, 4) + + if (c1 == NULL || c2 == NULL || c3 == NULL || c4 == NULL) + call tuniterr (nocolumn, unittab) + + # Create hash + + nrow = tbpsta (tp, TBL_NROWS) + ut = new_unhash (nrow, LEN_UNIT) + + # Read each row into hash + + do irow = 1, nrow { + # Read table columns + + call tbegtd (tp, c1, irow, factor) + call tbegtt (tp, c2, irow, Memc[oldunits], SZ_FNAME) + call tbegtt (tp, c3, irow, Memc[newunits], SZ_FNAME) + call tbegtb (tp, c4, irow, swap) + + # Check conversion factor + + if (factor <= 0.0) + call tuniterr (badfactor, Memc[oldunits]) + + # Swap the units string and the conversion factor + + if (swap) { + call strcpy (Memc[oldunits], Memc[temp], SZ_FNAME) + call strcpy (Memc[newunits], Memc[oldunits], SZ_FNAME) + call strcpy (Memc[temp], Memc[newunits], SZ_FNAME) + } + + # Check to see that old units aren't one of the final forms + + if (word_match (Memc[oldunits], FINALS) != 0) + call tuniterr (nofinal, Memc[oldunits]) + + # Parse the old and new units strings + + call strlwr (Memc[newunits]) + punit1 = parse_units (ab, Memc[newunits]) + + call strlwr (Memc[oldunits]) + punit2 = parse_units (ab, Memc[oldunits]) + + # The conversion factor is ratio of the two sets of units + + punit3 = div_unstr (punit1, punit2) + if (swap) { + TUN_FACTOR(punit3) = factor + } else { + TUN_FACTOR(punit3) = 1.0 / factor + } + + if (verbose) { + call str_unstr (punit3, Memc[temp], SZ_FNAME) + + call eprintf ("The conversion factor is %s\n\n") + call pargstr (Memc[temp]) + } + + # Add it to the hash + + call abrev_unstr (ab, Memc[oldunits], Memc[temp], SZ_FNAME) + call add_unhash (ut, Memc[temp], punit3) + + call free_unstr (punit1) + call free_unstr (punit2) + } + + # Close table and free memory + + call tbtclo (tp) + call sfree (sp) + return (ut) +end diff --git a/pkg/utilities/nttools/tunits/unstr.x b/pkg/utilities/nttools/tunits/unstr.x new file mode 100644 index 00000000..80bd65ba --- /dev/null +++ b/pkg/utilities/nttools/tunits/unstr.x @@ -0,0 +1,381 @@ +include "tunits.h" + +#* HISTORY * +#* B.Simon 07-Jan-99 Original + +# ABREV_UNSTR -- Replace units string with its abbreviation + +procedure abrev_unstr (ab, instr, outstr, maxch) + +pointer ab # i: abbreviation hash descriptor +char instr[ARB] # i: string to be abbreviated +char outstr[ARB] # o: abbreviated string +int maxch # i: max length of abbreviated string +#-- +int nc +pointer sp, temp + +int gstrcpy(), find_abrev () + +begin + if (find_abrev (ab, instr, outstr, maxch) == YES) + return + + call smark (sp) + call salloc (temp, LEN_UNIT, TY_CHAR) + + nc = gstrcpy (instr, Memc[temp], LEN_UNIT) + if (nc == 1 || instr[nc] != 's') { + call strcpy (instr, outstr, maxch) + + } else { + Memc[temp+nc-1] = EOS + if (find_abrev (ab, Memc[temp], outstr, maxch) == NO) + call strcpy (Memc[temp], outstr, maxch) + } + + call sfree (sp) +end + +# COPY_UNSTR -- Copy a units descriptor + +pointer procedure copy_unstr (punit1) + +pointer punit1 # i: units descriptor to be copied +#-- +int idx +pointer punit2 + +begin + # Allocate structure to hold units + + call calloc (punit2, LEN_TUNSTRUCT, TY_INT) + + # Copy numeric factor + + TUN_FACTOR(punit2) = TUN_FACTOR(punit1) + + # Copy units and their powers + + do idx = 1, MAXUNIT { + if (TUN_UNPTR(punit1,idx) == NULL) + break + + call malloc (TUN_UNPTR(punit2,idx), LEN_UNIT, TY_CHAR) + call strcpy (TUN_UNITS(punit1,idx), TUN_UNITS(punit2,idx), + LEN_UNIT) + + TUN_POWER(punit2,idx) = TUN_POWER(punit1,idx) + } + + return (punit2) +end +# DIV_UNSTR -- Divide one set of units by another + +pointer procedure div_unstr (punit1, punit2) + +pointer punit1 # i: descriptor for first set of units +pointer punit2 # i: descriptor for second set of units +#-- +int idx, jdx, kdx, power +pointer punit3 + +int find_unstr() + +begin + # Allocate structure to hold units + + call calloc (punit3, LEN_TUNSTRUCT, TY_INT) + + # Compute the new factor + + TUN_FACTOR(punit3) = TUN_FACTOR(punit1) / TUN_FACTOR(punit2) + + # Find units in both descriptors and subtract their powers + + jdx = 1 + do idx = 1, MAXUNIT { + if (TUN_UNPTR(punit1,idx) == NULL) + break + + kdx = find_unstr (punit2, TUN_UNITS(punit1, idx)) + if (kdx == 0) + next + + power = TUN_POWER(punit1,idx) - TUN_POWER(punit2,kdx) + if (power == 0) + next + + call malloc (TUN_UNPTR(punit3,jdx), LEN_UNIT, TY_CHAR) + call strcpy (TUN_UNITS(punit1,idx), TUN_UNITS(punit3,jdx), + LEN_UNIT) + + TUN_POWER(punit3,jdx) = power + jdx = jdx + 1 + + } + + # Find units only in a single descriptor and add them to the + # new descriptor + + do idx = 1, MAXUNIT { + if (TUN_UNPTR(punit1,idx) == NULL) + break + + if (find_unstr (punit2, TUN_UNITS(punit1, idx)) == 0) { + call malloc (TUN_UNPTR(punit3,jdx), LEN_UNIT, TY_CHAR) + call strcpy (TUN_UNITS(punit1,idx), TUN_UNITS(punit3,jdx), + LEN_UNIT) + + TUN_POWER(punit3,jdx) = TUN_POWER(punit1,idx) + jdx = jdx + 1 + } + } + + do idx = 1, MAXUNIT { + if (TUN_UNPTR(punit2,idx) == NULL) + break + + if (find_unstr (punit1, TUN_UNITS(punit2, idx)) == 0) { + call malloc (TUN_UNPTR(punit3,jdx), LEN_UNIT, TY_CHAR) + call strcpy (TUN_UNITS(punit2,idx), TUN_UNITS(punit3,jdx), + LEN_UNIT) + + TUN_POWER(punit3,jdx) = - TUN_POWER(punit2,idx) + jdx = jdx + 1 + } + } + + return (punit3) +end + +# FIND_UNSTR -- Find location of units string in descriptor + +int procedure find_unstr (punit, units) + +pointer punit # i: units descriptor +char units[ARB] # i: units string to search for +#-- +int idx +bool streq() + +begin + do idx = 1, MAXUNIT { + if (TUN_UNPTR(punit,idx) == NULL) + break + + if (streq (TUN_UNITS(punit,idx), units)) + return (idx) + } + + return (0) +end + +# FREE_UNSTR -- Release memory used by a units descriptor + +procedure free_unstr (punit) + +pointer punit # i: units descriptor +#-- +int idx + +begin + do idx = 1, MAXUNIT { + if (TUN_UNPTR(punit,idx) == NULL) + break + + call mfree (TUN_UNPTR(punit,idx), TY_CHAR) + } + + call mfree (punit, TY_INT) +end + +# MUL_UNSTR -- Multiply two sets of units together + +pointer procedure mul_unstr (punit1, punit2) + +pointer punit1 # i: descriptor for first set of units +pointer punit2 # i: descriptor for second set of units +#-- +int idx, jdx, kdx, power +pointer punit3 + +int find_unstr() + +begin + # Allocate structure to hold units + + call calloc (punit3, LEN_TUNSTRUCT, TY_INT) + + # Compute the new factor + + TUN_FACTOR(punit3) = TUN_FACTOR(punit1) * TUN_FACTOR(punit2) + + # Find units in both descriptors and add their powers + + jdx = 1 + do idx = 1, MAXUNIT { + if (TUN_UNPTR(punit1,idx) == NULL) + break + + kdx = find_unstr (punit2, TUN_UNITS(punit1, idx)) + if (kdx == 0) + next + + power = TUN_POWER(punit1,idx) + TUN_POWER(punit2,kdx) + if (power == 0) + next + + call malloc (TUN_UNPTR(punit3,jdx), LEN_UNIT, TY_CHAR) + call strcpy (TUN_UNITS(punit1,idx), TUN_UNITS(punit3,jdx), + LEN_UNIT) + + TUN_POWER(punit3,jdx) = power + jdx = jdx + 1 + + } + + # Find units only in a single descriptor and add them to the + # new descriptor + + do idx = 1, MAXUNIT { + if (TUN_UNPTR(punit1,idx) == NULL) + break + + if (find_unstr (punit2, TUN_UNITS(punit1, idx)) == 0) { + call malloc (TUN_UNPTR(punit3,jdx), LEN_UNIT, TY_CHAR) + call strcpy (TUN_UNITS(punit1,idx), TUN_UNITS(punit3,jdx), + LEN_UNIT) + + TUN_POWER(punit3,jdx) = TUN_POWER(punit1,idx) + jdx = jdx + 1 + } + } + + do idx = 1, MAXUNIT { + if (TUN_UNPTR(punit2,idx) == NULL) + break + + if (find_unstr (punit1, TUN_UNITS(punit2, idx)) == 0) { + call malloc (TUN_UNPTR(punit3,jdx), LEN_UNIT, TY_CHAR) + call strcpy (TUN_UNITS(punit2,idx), TUN_UNITS(punit3,jdx), + LEN_UNIT) + + TUN_POWER(punit3,jdx) = TUN_POWER(punit2,idx) + jdx = jdx + 1 + } + } + + return (punit3) +end + +# NUM_UNSTR -- Convert a token to an integer + +int procedure num_unstr (value) + +char value[ARB] # i: string containing token value +#-- +int ic, nc, num + +int ctoi() + +begin + ic = 1 + nc = ctoi (value, ic, num) + return (num) +end + +# POW_UNSTR -- Raise a set of units to an integer power + +pointer procedure pow_unstr (punit1, power) + +pointer punit1 # i: units descriptor to be raised to power +int power +#-- +int idx +pointer punit2 + +begin + # Allocate structure to hold units + + call calloc (punit2, LEN_TUNSTRUCT, TY_INT) + + # Compute the new factor + + TUN_FACTOR(punit2) = TUN_FACTOR(punit1) ** power + + # Find units in both descriptors and add their powers + + if (power != 0) { + for (idx = 1; idx <= MAXUNIT; idx = idx + 1) { + if (TUN_UNPTR(punit1,idx) == NULL) + break + + call malloc (TUN_UNPTR(punit2,idx), LEN_UNIT, TY_CHAR) + call strcpy (TUN_UNITS(punit1,idx), TUN_UNITS(punit2,idx), + LEN_UNIT) + + TUN_POWER(punit2,idx) = TUN_POWER(punit1,idx) * power + } + } + + return (punit2) +end + +# SET_UNSTR -- Make a new units description from a units string and its power + +pointer procedure set_unstr (ab, units, power) + +pointer ab # i: hash of units abbreviations +char units[ARB] # i: units string +int power # i: power of the units +#-- +pointer punit + +begin + # Allocate structure to hold units + + call calloc (punit, LEN_TUNSTRUCT, TY_INT) + call malloc (TUN_UNPTR(punit,1), LEN_UNIT, TY_CHAR) + + # Set the first slot in the structure to hold the string + # and power passed to this procedure + + TUN_FACTOR(punit) = 1.0 + TUN_POWER(punit,1) = power + call abrev_unstr (ab, units, TUN_UNITS(punit,1), LEN_UNIT) + + return (punit) +end + +# STR_UNSTR -- Convert units structure into a string + +procedure str_unstr (punit, str, maxch) + +pointer punit # i: units descriptor +char str[ARB] # o: string representation of units +int maxch # i: max length of string +#-- +int ic, idx + +int strlen(), gstrcpy(), itoc() + +begin + call sprintf (str, maxch, "%g") + call pargd (TUN_FACTOR(punit)) + + ic = strlen (str) + 1 + + do idx = 1, MAXUNIT { + if (TUN_UNPTR(punit,idx) == NULL) + break + + ic = ic + gstrcpy ("*", str[ic], maxch-ic+1) + ic = ic + gstrcpy (TUN_UNITS(punit,idx), str[ic], maxch+ic-1) + + if (TUN_POWER(punit,idx) != 1) { + ic = ic + gstrcpy ("^", str[ic], maxch-ic+1) + ic = ic + itoc (TUN_POWER(punit,idx), str[ic], maxch-ic+1) + } + } +end diff --git a/pkg/utilities/nttools/tupar.par b/pkg/utilities/nttools/tupar.par new file mode 100644 index 00000000..ae3f77de --- /dev/null +++ b/pkg/utilities/nttools/tupar.par @@ -0,0 +1,9 @@ +table,s,a,"",,,"list of tables" +same,b,h,no,,,"apply same instructions to all tables?" +verbose,b,h,yes,,,"print name of each table?" +readonly,b,h,no,,,"open tables readonly?" +inplace,b,h,no,,,"edit tables inplace?" +quit_default,b,h,no,,,"default action for quit vs exit" +delete_default,b,h,yes,,,"default action for delete or replace" +go_ahead,b,q,no,,," ?" +mode,s,h,"al",,, diff --git a/pkg/utilities/nttools/tupar/mkpkg b/pkg/utilities/nttools/tupar/mkpkg new file mode 100644 index 00000000..10371af4 --- /dev/null +++ b/pkg/utilities/nttools/tupar/mkpkg @@ -0,0 +1,12 @@ +# Update the tupar application code in the ttools package library +# Author: HODGE, 2-FEB-1988 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + tupar.x "tupar.h" + tuinstr.x "tupar.h" + ; diff --git a/pkg/utilities/nttools/tupar/tuinstr.x b/pkg/utilities/nttools/tupar/tuinstr.x new file mode 100644 index 00000000..32adf46d --- /dev/null +++ b/pkg/utilities/nttools/tupar/tuinstr.x @@ -0,0 +1,971 @@ +include # defines IS_WHITE +include +include "tupar.h" # defines TUPAR_EXIT & TUPAR_QUIT + +# tu_instr -- execute edit instruction +# Execute one instruction regarding header parameters for a table: +# get, put, delete, replace, type, or list. +# The flag DONE will be set to true if the instruction is 'q' or +# if the user's response to a prompt is EOF. Prompting is turned +# off if the input is redirected. +# +# Phil Hodge, 28-Mar-1988 Subroutine created +# Phil Hodge, 9-Sep-1988 Prompt changed for delete & replace +# Phil Hodge, 9-Mar-1989 Change data type of header parm from char to int. +# Phil Hodge, 23-Aug-1991 Include eq_flag, allowing quit without saving changes +# Phil Hodge, 9-Jul-1993 Set modified=true if header was changed. +# Phil Hodge, 7-Mar-1995 In tu_putpar, also put a comment, if present. +# Phil Hodge, 17-May-1995 In tu_putpar, allow ' as well as " as delimiter. +# Phil Hodge, 22-May-1996 Add "k" instruction. +# Phil Hodge, 5-Jun-1997 In tu_getpar and tu_listpar, also print comments +# Phil Hodge, 2-Jul-1998 In tu_putpar, check for "true" or "t" for a boolean +# parameter; get data type from existing parameter; +# in tu_listpar, print boolean as "yes" or "no". +# Ellyne Kinney, 2-Feb-1999 Testing Automatic updates of IRAFRA under CVS +# 13th try. + +procedure tu_instr (tp, linebuf, readonly, prompt, from_stdin, + iredir, save_instr, isbuf, bufsize, ibp, + modified, eq_flag, done, istat) + +pointer tp # i: pointer to table descriptor +char linebuf[ARB] # o: scratch for input line +bool readonly # i: was table opened readonly? +bool prompt # i: prompt for input? +bool from_stdin # i: get input from STDIN (or from buffer) +bool iredir # i: input redirected? +bool save_instr # i: save instruction? +pointer isbuf # io: pointer to instruction buffer +int bufsize # io: current size of instruction buffer +int ibp # io: current index in instruction buffer +bool modified # io: set to true if the header was modified +int eq_flag # o: exit or quit +bool done # o: set to true if done with current table +int istat # o: > 0 if put or delete but table is readonly +#-- +char instr[11] # instruction from user: q, g, p, etc. +int ip # index in linebuf +int clen # length of command (to check for "!") +bool verify # verify before delete or replace? +bool incl_num # include par numbers when listing keywords? +int ctowrd(), tu_gline(), tu_rd_instr() +int strlen() +errchk tu_getpar, tu_putpar, tu_delpar, tu_replpar, tu_ch_name + +begin + # default value in case user finishes by giving an EOF + eq_flag = TUPAR_EXIT + + istat = 0 + done = false + + if (from_stdin) { + # Read an instruction from STDIN into linebuf. + if (prompt) { + call eprintf (":") + call flush (STDOUT) + call flush (STDERR) + } + if (tu_gline (STDIN, linebuf) == EOF) + done = true + } else { + # Read an instruction from buffer into linebuf. + if (tu_rd_instr (Memc[isbuf], ibp, linebuf) == EOF) + done = true + } + if ( done ) + return + + ip = 1 + if (ctowrd (linebuf, ip, instr, 11) <= 0) # a blank line + return + if (instr[1] == '#') # a comment line + return + + if (instr[1] == 'e') { + eq_flag = TUPAR_EXIT + done = true + + } else if (instr[1] == 'q') { + clen = strlen (instr) + if (instr[clen] == '!') + eq_flag = TUPAR_QUIT_NC + else + eq_flag = TUPAR_QUIT + done = true + + } else if (instr[1] == 'g') { + + call tu_getpar (tp, linebuf, ip, instr, + save_instr, isbuf, bufsize, ibp) + + } else if (instr[1] == 'p') { + + if (readonly) { + istat = 1 + return + } + call tu_putpar (tp, linebuf, ip, instr, + save_instr, isbuf, bufsize, ibp) + modified = true + + } else if (instr[1] == 'd') { + + # Delete a header parameter specified by name or by number. + + if (readonly) { + istat = 1 + return + } + verify = ( ! iredir ) && (instr[2] != '!') + call tu_delpar (tp, linebuf, ip, verify, + save_instr, isbuf, bufsize, ibp, modified) + + } else if (instr[1] == 'r') { + + # Replace a header parameter specified by name or by number. + + if (readonly) { + istat = 1 + return + } + verify = ( ! iredir ) && (instr[2] != '!') + call tu_replpar (tp, linebuf, ip, prompt, from_stdin, + verify, save_instr, isbuf, bufsize, ibp, + modified, done) + + } else if (instr[1] == 'k') { + + # Change keyword name. + + if (readonly) { + istat = 1 + return + } + call tu_ch_name (tp, linebuf, ip, + save_instr, isbuf, bufsize, ibp, + modified) + + } else if (instr[1] == 't' || instr[1] == 'l') { + + # Type or list parameters; list means include keyword number. + + incl_num = instr[1] == 'l' # list rather than type + call tu_listpar (tp, linebuf, ip, incl_num, + save_instr, isbuf, bufsize, ibp) + + } else { + call eprintf ("The options are:\n") + call eprintf ( + " e, q, g, p, d, r, t, l\n") + call eprintf ( + " (exit, quit, get, put, delete, replace, type, list)\n") + call eprintf ( + " e exit the task, saving changes\n") + call eprintf ( + " q quit the task WITHOUT saving any changes\n") + call eprintf ( + " g keyword get parameter with keyword `keyword'\n") + call eprintf ( + " p keyword value put parameter `keyword'\n") + call eprintf ( + " d keyword delete parameter `keyword'\n") + call eprintf ( + " r keyword replace parameter `keyword'\n") + call eprintf ( + " k oldkey newkey change keyword name\n") + call eprintf ( + " t type the parameters\n") + call eprintf ( + " l list parameters and show par numbers\n") + call eprintf ( + " see help for further info about these instructions\n") + } +end + + +# tu_getpar -- get a parameter +# The value of a parameter specified by name (not by number) will be gotten +# and displayed. If the keyword is not found in the header, nothing will +# be displayed (i.e. no error message). If the keyword is HISTORY, COMMENT, +# or a blank, then all keywords of that type will be displayed. + +procedure tu_getpar (tp, linebuf, ip, instr, + save_instr, isbuf, bufsize, ibp) + +pointer tp # i: pointer to table descriptor +char linebuf[ARB] # i: input line +int ip # io: index in linebuf +char instr[ARB] # i: the instruction (needed for data type) +bool save_instr # i: save instruction? +pointer isbuf # io: pointer to instruction buffer +int bufsize # io: current size of instruction buffer +int ibp # io: current index in instruction buffer +#-- +char keyword[SZ_KEYWORD] # keyword for parameter +char kwrd[SZ_KEYWORD] # keyword returned by tbhgnp +char text[SZ_PARREC] # buffer for value of parameter +char comment[SZ_PARREC] # buffer for comment, if any +int dtype # data type (TY_CHAR, etc) +double dblval +real realval +int intval +bool boolval +int npar # current number of parameters +int k # loop index +double tbhgtd() +real tbhgtr() +int tbhgti(), tbpsta() +bool tbhgtb() +int ctowrd() +bool streq() + +begin + npar = tbpsta (tp, TBL_NPAR) + + if (ctowrd (linebuf, ip, keyword, SZ_KEYWORD) <= 0) { + call eprintf ("syntax: g keyword\n") + return # get next instruction + } + call strupr (keyword) + + # Get comment, if it exists. + iferr (call tbhgcm (tp, keyword, comment, SZ_PARREC)) + comment[1] = EOS + + if (instr[2] == 'r') { + ifnoerr (realval = tbhgtr (tp, keyword)) { + call printf ("%s = %g") + call pargstr (keyword) + call pargr (realval) + if (comment[1] == EOS) { + call printf ("\n") + } else { + call printf (" %s\n") + call pargstr (comment) + } + } + } else if (instr[2] == 'd') { + ifnoerr (dblval = tbhgtd (tp, keyword)) { + call printf ("%s = %g") + call pargstr (keyword) + call pargd (dblval) + if (comment[1] == EOS) { + call printf ("\n") + } else { + call printf (" %s\n") + call pargstr (comment) + } + } + } else if (instr[2] == 'i') { + ifnoerr (intval = tbhgti (tp, keyword)) { + call printf ("%s = %d") + call pargstr (keyword) + call pargi (intval) + if (comment[1] == EOS) { + call printf ("\n") + } else { + call printf (" %s\n") + call pargstr (comment) + } + } + } else if (instr[2] == 'b') { + ifnoerr (boolval = tbhgtb (tp, keyword)) { + call printf ("%s = %b") + call pargstr (keyword) + call pargb (boolval) + if (comment[1] == EOS) { + call printf ("\n") + } else { + call printf (" %s\n") + call pargstr (comment) + } + } + } else { + if (streq (keyword, "HISTORY") || streq (keyword, "COMMENT") || + keyword[1] == EOS) { + # Print all history or comment or blank-keyword records. + do k = 1, npar { + call tbhgnp (tp, k, kwrd, dtype, text) + if (streq (keyword, kwrd)) { + call printf ("%s = %s\n") + call pargstr (keyword) + call pargstr (text) + } + } + } else { + ifnoerr (call tbhgtt (tp, keyword, text, SZ_PARREC)) { + if (comment[1] == EOS) { + call printf ("%s = %s\n") + call pargstr (keyword) + call pargstr (text) + } else { + call printf ("%s = '%s' %s\n") + call pargstr (keyword) + call pargstr (text) + call pargstr (comment) + } + } + } + } + + if (save_instr) + call tu_save_instr (linebuf, isbuf, bufsize, ibp) +end + + +# tu_putpar -- add or replace a parameter +# A parameter specified by name (not by number) is put into the table. +# If the parameter already exists it will be replaced (and the data type +# may be changed); otherwise, it will be added. + +procedure tu_putpar (tp, linebuf, ip, instr, + save_instr, isbuf, bufsize, ibp) + +pointer tp # i: pointer to table descriptor +char linebuf[ARB] # i: input line +int ip # io: index in linebuf +char instr[ARB] # i: the instruction (needed for data type) +bool save_instr # i: save instruction? +pointer isbuf # io: pointer to instruction buffer +int bufsize # io: current size of instruction buffer +int ibp # io: current index in instruction buffer +#-- +pointer sp +pointer value # scratch for a string value +char keyword[SZ_KEYWORD] # keyword for parameter +int dtype # data type code for parameter +bool found # parameter already in header? (ignored) +double dblval +real realval +int intval +bool boolval +int npar # current number of parameters +int tbpsta() +int nchar, ctowrd(), ctod(), ctoi(), nscan(), strlen() +bool streq() + +begin + npar = tbpsta (tp, TBL_NPAR) + + if (ctowrd (linebuf, ip, keyword, SZ_KEYWORD) <= 0) { + call eprintf ("syntax: p keyword value\n") + return + } + + call smark (sp) + call salloc (value, SZ_FNAME, TY_CHAR) + + # Set the data type. If the user specified a type, use that. + # If none was specified, find out whether the parameter is + # already in the header, and if so, use the existing type. + if (instr[2] == 'r') + dtype = TY_REAL + else if (instr[2] == 'd') + dtype = TY_DOUBLE + else if (instr[2] == 'i') + dtype = TY_INT + else if (instr[2] == 'b') + dtype = TY_BOOL + else if (instr[2] == 't') + dtype = TY_CHAR + else + call tu_partype (tp, keyword, dtype, found) + + # In each section, we use ctowrd or ctod (or something), not only + # to extract the value but also to skip past it so we can check for + # a comment. + if (dtype == TY_REAL) { + if (ctod (linebuf, ip, dblval) > 0) + realval = dblval + else + realval = INDEFR + call tbhadr (tp, keyword, realval) + } else if (dtype == TY_DOUBLE) { + if (ctod (linebuf, ip, dblval) < 1) + dblval = INDEFD + call tbhadd (tp, keyword, dblval) + } else if (dtype == TY_INT) { + if (ctoi (linebuf, ip, intval) < 1) + intval = INDEFI + call tbhadi (tp, keyword, intval) + } else if (dtype == TY_BOOL) { + nchar = ctowrd (linebuf, ip, Memc[value], SZ_FNAME) + call strlwr (Memc[value]) + call sscan (Memc[value]) + call gargb (boolval) + if (nscan() < 1) { + if (streq (Memc[value], "true") || streq (Memc[value], "t") || + streq (Memc[value], "1")) + boolval = true + else + boolval = false + } + call tbhadb (tp, keyword, boolval) + + } else { + + while (IS_WHITE(linebuf[ip])) + ip = ip + 1 + + if (linebuf[ip] == '"' || linebuf[ip] == '\'') { + nchar = ctowrd (linebuf, ip, Memc[value], SZ_FNAME) + call tbhadt (tp, keyword, Memc[value]) + } else { + call tbhadt (tp, keyword, linebuf[ip]) + # Set ip to point to end of line because there's no comment. + ip = strlen (linebuf) + 1 + } + } + + # Check for a comment. + while (IS_WHITE(linebuf[ip])) + ip = ip + 1 + if (linebuf[ip] != EOS) + call tbhpcm (tp, keyword, linebuf[ip]) + + if (save_instr) + call tu_save_instr (linebuf, isbuf, bufsize, ibp) + + call sfree (sp) +end + + +# tu_delpar -- delete a parameter +# A parameter is to be deleted. The user will be prompted for confirmation +# if the input is not redirected and the instruction was not 'q!'. + +procedure tu_delpar (tp, linebuf, ip, verify, + save_instr, isbuf, bufsize, ibp, modified) + +pointer tp # i: pointer to table descriptor +char linebuf[ARB] # i: input line +int ip # i: index in linebuf +bool verify # i: ask for verification before deleting? +bool save_instr # i: save instruction? +pointer isbuf # io: pointer to instruction buffer +int bufsize # io: current size of instruction buffer +int ibp # io: current index in instruction buffer +bool modified # io: set to true if parameter was deleted +#-- +char keyword[SZ_KEYWORD] # keyword for parameter +char text[SZ_PARREC] # buffer for value of parameter +char char_type # data type as a letter +int dtype # data type +int par1, par2 # range of par numbers to delete +int i # loop index +int parnum # keyword number +int ctowrd() +bool clgetb() + +begin + i = ip + + if (ctowrd (linebuf, i, keyword, SZ_KEYWORD) <= 0) { + call eprintf ("syntax: d keyword (or d parnum)\n") + return + } + + # Get the parameter numbers; = 0,-1 if not found. + call tu_parnum (tp, linebuf[ip], par1, par2) + + # Delete in increasing numerical order. That means that if we + # delete every one, it will be the same par number each time. + # Whenever we don't delete one, we increment parnum. + parnum = par1 + do i = par1, par2 { + # Get parameter by number. + call tbhgnp (tp, parnum, keyword, dtype, text) + if (dtype == 0) + call error (1, "tu_delpar: keyword miscount") + + if ( verify ) { + # Change data type to a char. + switch (dtype) { + case TY_REAL: + char_type = 'r' + case TY_INT: + char_type = 'i' + case TY_DOUBLE: + char_type = 'd' + case TY_BOOL: + char_type = 'b' + default: + char_type = 't' + } + # Ask for confirmation before deleting. + call clputb ("go_ahead", clgetb ("delete_default")) + call eprintf ( + "The following parameter is to be deleted:\n") + call eprintf ("%-8s %c %s\n") + call pargstr (keyword) + call pargc (char_type) + call pargstr (text) + call eprintf (" ... OK to delete") + call flush (STDERR) + if (clgetb ("go_ahead")) { + call tbhdel (tp, parnum) # delete it + modified = true + } else { + parnum = parnum + 1 # point to next parameter + } + } else { + # Delete without asking for confirmation. + call tbhdel (tp, parnum) + modified = true + } + } + + # Note that we may save this instruction even if the parameter + # was not found in the current table. + if (save_instr) + call tu_save_instr (linebuf, isbuf, bufsize, ibp) +end + + +# tu_replpar -- replace a parameter +# Replace an existing parameter, specified either by name or by number. +# The instruction and the replacement string will be saved in the instruction +# buffer if appropriate. Neither will be saved, however, if the keyword is +# not found in the first table. (This is in contrast to the behavior of the +# delete instruction.) The user will be prompted for confirmation if the +# input is not redirected and the instruction was not 'r!'. + +procedure tu_replpar (tp, linebuf, ip, prompt, from_stdin, + verify, save_instr, isbuf, bufsize, ibp, + modified, done) + +pointer tp # i: pointer to table descriptor +char linebuf[ARB] # i: input line +int ip # i: index in linebuf +bool prompt # i: prompt for input? +bool from_stdin # i: get instructions from STDIN? +bool verify # i: ask for verification before deleting? +bool save_instr # i: save instruction? +pointer isbuf # io: pointer to instruction buffer +int bufsize # io: current size of instruction buffer +int ibp # io: current index in instruction buffer +bool modified # io: set to true if parameter was replaced +bool done # io: set to false if done with current table +#-- +char keyword[SZ_KEYWORD] # keyword for parameter +char text[SZ_PARREC] # buffer for value of parameter +char rtext[SZ_PARREC] # replacement value for a parameter +char char_type # data type as a letter +int dtype # data type (TY_CHAR, etc) +int par1, par2 # range of keywords to replace +int i # loop index for keyword number +int ctowrd(), tu_gline(), tu_rd_instr() +bool clgetb() + +begin + i = ip + + if (ctowrd (linebuf, i, keyword, SZ_KEYWORD) <= 0) { + call eprintf ("syntax: r keyword (or r parnum)\n") + return + } + + # Save the instruction; the replacement value(s) will be + # saved within the loop over keyword number. + if (save_instr) + call tu_save_instr (linebuf, isbuf, bufsize, ibp) + + # Get the parameter numbers, 0,-1 if not found. + call tu_parnum (tp, linebuf[ip], par1, par2) + + do i = par1, par2 { + # Get parameter by number. + call tbhgnp (tp, i, keyword, dtype, text) + if (dtype == 0) + call error (1, "tu_replpar: keyword miscount") + + # Change data type to a char. + switch (dtype) { + case TY_REAL: + char_type = 'r' + case TY_INT: + char_type = 'i' + case TY_DOUBLE: + char_type = 'd' + case TY_BOOL: + char_type = 'b' + default: + char_type = 't' + } + + if (prompt) { + # Display current value. + call eprintf ( + "keyword %s, type %c; give replacement value:\n") + call pargstr (keyword) + call pargc (char_type) + call eprintf ("%s\n") + call pargstr (text) + } + # Read replacement text, either from STDIN or from instr buffer. + if (from_stdin) { + if (tu_gline (STDIN, rtext) == EOF) { + done = true + return + } + } else { + if (tu_rd_instr (Memc[isbuf], ibp, rtext) == EOF) { + done = true + return + } + } + + # Tab is saved in the instruction buffer to mean that the + # value should not be changed. This allows replacing a value + # with blanks. + if (rtext[1] == EOS) { + call eprintf ("no action taken\n") + call strcpy ("\t", rtext, SZ_PARREC) + + } else if (rtext[1] == '\t') { + ; + + } else if (verify) { + # Prompt for confirmation. + call clputb ("go_ahead", clgetb ("delete_default")) + call eprintf ("Current parameter and its replacement are:\n") + call eprintf ("%-8s %c %s\n") + call pargstr (keyword) + call pargc (char_type) + call pargstr (text) + call eprintf ("%-8s %c %s\n") + call pargstr (keyword) + call pargc (char_type) + call pargstr (rtext) + call eprintf (" ... OK to replace") + call flush (STDERR) + if (clgetb ("go_ahead")) { + call tbhpnp (tp, i, keyword, dtype, rtext) # replace it + modified = true + } else { + call eprintf ("not replaced\n") + } + + } else { + # Replace the value without prompting. + call tbhpnp (tp, i, keyword, dtype, rtext) + modified = true + } + + # Save the replacement value. + if (save_instr) + call tu_save_instr (rtext, isbuf, bufsize, ibp) + } +end + +# tu_ch_name -- change keyword name +# Replace the name of an existing keyword without changing either the +# value or comment. +# The instruction and the replacement string will be saved in the instruction +# buffer if appropriate. Neither will be saved, however, if the keyword is +# not found in the first table. The user will be prompted for confirmation +# if the input is not redirected and the instruction was not 'k!'. + +procedure tu_ch_name (tp, linebuf, ip, + save_instr, isbuf, bufsize, ibp, + modified) + +pointer tp # i: pointer to table descriptor +char linebuf[ARB] # i: input line +int ip # i: index in linebuf +bool save_instr # i: save instruction? +pointer isbuf # io: pointer to instruction buffer +int bufsize # io: current size of instruction buffer +int ibp # io: current index in instruction buffer +bool modified # io: set to true if parameter was replaced +#-- +char oldkey[SZ_KEYWORD] # current keyword +char newkey[SZ_KEYWORD+1] # new keyword; extra space for testing length +int i +int parnum # parameter specified by number (zero) +bool insufficient_input # true if not enough input was given +int ctowrd(), strlen() +errchk tbhckn + +begin + i = ip + + insufficient_input = false # initial value + + if (ctowrd (linebuf, i, oldkey, SZ_KEYWORD) <= 0) + insufficient_input = true + if (ctowrd (linebuf, i, newkey, SZ_KEYWORD+1) <= 0) + insufficient_input = true + + if (insufficient_input) { + call eprintf ("syntax: k oldkey newkey\n") + return + } + + if (strlen (newkey) > SZ_KEYWORD) { + call eprintf ("new keyword name is too long; limit is %d\n") + call pargi (SZ_KEYWORD) + return + } + + # Save the instruction. + if (save_instr) + call tu_save_instr (linebuf, isbuf, bufsize, ibp) + + # Replace the keyword name. + parnum = 0 + call tbhckn (tp, oldkey, parnum, newkey) + modified = true +end + + +# tu_listpar -- list parameters +# Either all parameters or a range of parameters specified by number +# may be displayed. The parameter numbers may optionally be displayed. + +procedure tu_listpar (tp, linebuf, ip, incl_num, + save_instr, isbuf, bufsize, ibp) + +pointer tp # i: pointer to table descriptor +char linebuf[ARB] # i: input line +int ip # io: index in linebuf +bool incl_num # i: include number when listing parameters? +bool save_instr # i: save instruction? +pointer isbuf # io: pointer to instruction buffer +int bufsize # io: current size of instruction buffer +int ibp # io: current index in instruction buffer +#-- +char keyword[SZ_KEYWORD] # keyword for parameter +char text[SZ_PARREC] # buffer for value of parameter +char comment[SZ_PARREC] # buffer for comment, if any +char char_type # data type as a letter +int dtype # data type (a character constant) +int j1, j2 # loop bounds: first & last par numbers +int npar # current number of parameters +int k # loop index +int tbpsta() +int ctoi() + +begin + npar = tbpsta (tp, TBL_NPAR) + + # Get the range of keywords to list. + if (ctoi (linebuf, ip, j1) <= 0) { + j1 = 1 + j2 = npar + } else if (ctoi (linebuf, ip, j2) <= 0) { + j2 = j1 + } + if (j2 < j1) { + k = j1 # swap j1, j2 + j1 = j2 + j2 = k + } + if (j1 > npar || j2 < 1) { + call eprintf ("out of range; max is %d\n") + call pargi (npar) + j1 = 1 # so loop will not be executed + j2 = 0 + } + j1 = max (j1, 1) + j2 = min (j2, npar) + do k = j1, j2 { + call tbhgnp (tp, k, keyword, dtype, text) + call tbhgcm (tp, keyword, comment, SZ_PARREC) + # Change data type to a char. + switch (dtype) { + case TY_REAL: + char_type = 'r' + case TY_INT: + char_type = 'i' + case TY_DOUBLE: + char_type = 'd' + case TY_BOOL: + char_type = 'b' + default: + char_type = 't' + } + if (incl_num) { # include keyword number + call printf ("%2d ") + call pargi (k) + } + call printf ("%-8s %c") + call pargstr (keyword) + call pargc (char_type) + if (comment[1] == EOS) { + if (dtype == TY_BOOL && text[1] == '1') { + call printf (" yes\n") + } else if (dtype == TY_BOOL && text[1] == '0') { + call printf (" no\n") + } else { + call printf (" %s\n") + call pargstr (text) + } + } else { # also print comment + if (char_type == 't') { + call printf (" '%s'") # enclose text in quotes + call pargstr (text) + } else if (dtype == TY_BOOL) { + if (text[1] == '1') { + call printf (" yes") + } else if (text[1] == '0') { + call printf (" no") + } else { + call printf (" %s") + call pargstr (text) + } + } else { + call printf (" %s") # no quotes needed + call pargstr (text) + } + call printf (" %s\n") + call pargstr (comment) + } + } + + if (save_instr) + call tu_save_instr (linebuf, isbuf, bufsize, ibp) +end + + +# tu_gline -- getline without newline +# Read a line using getline, and replace the newline character with EOS. +# Either EOF or the number of char read before the newline will be returned. + +int procedure tu_gline (fd, linebuf) + +int fd # i: identifies input file +char linebuf[ARB] # o: output buffer for text that was read +#-- +int istat +int k +int getline() + +begin + istat = getline (fd, linebuf) + if (istat == EOF) + return (istat) + + k = 1 + while (linebuf[k] != EOS) { + if (linebuf[k] == '\n') { + linebuf[k] = EOS + break + } + k = k + 1 + } + return (k-1) +end + + +# tu_parnum -- get parameter number +# Either one or a pair of keywords may be given as input in the string +# 'keyword', and each may be specified either by name or by number. +# This routine reads the numbers and/or names and converts keyword +# names to numbers. If the parameter (or either of two) is not found, or +# if the number is larger than the number of header keywords, par1 +# will be set to 0 and par2 to -1. If only one keyword is given, par2 +# will be set equal to par1. + +procedure tu_parnum (tp, keyword, par1, par2) + +pointer tp # i: pointer to table descriptor +char keyword[ARB] # i: keyword name or number +int par1 # o: number of first parameter to delete +int par2 # o: number of last parameter to delete +#-- +char key1[SZ_KEYWORD], key2[SZ_KEYWORD] +int ip # counter within keyword +int ipi # counter in key1 or key2 +int temp # for swapping par1 & par2 +int npar # total number of header parameters +int nchar +int ctowrd(), ctoi(), tbpsta() + +begin + npar = tbpsta (tp, TBL_NPAR) + # Default values so a loop from par1 to par2 will not execute. + par1 = 0 + par2 = -1 + + # Extract the first (and possibly only) word. + ip = 1 + nchar = ctowrd (keyword, ip, key1, SZ_KEYWORD) + if (nchar < 1) + return # nothing given + + # Interpret the first word as a number or name. First try to + # read it as an integer. If it's not an integer, or if there's + # something after an integer part (e.g. key1 = "37test"), then + # treat it as a keyword name. + ipi = 1 + nchar = ctoi (key1, ipi, par1) + if ( (nchar <= 0) || (key1[ipi] != EOS) ) + call tbhfkw (tp, key1, par1) # get the par number + + if (par1 < 1) { + call eprintf ("warning: keyword `%s' not found\n") + call pargstr (key1) + return + } + + nchar = ctowrd (keyword, ip, key2, SZ_KEYWORD) # read second word + if (nchar < 1) { + par2 = par1 # there was only one word + } else { + ipi = 1 + nchar = ctoi (key2, ipi, par2) + if ( (nchar <= 0) || (key2[ipi] != EOS) ) + call tbhfkw (tp, key2, par2) + if (par2 < 1) { + call eprintf ("warning: keyword `%s' not found\n") + call pargstr (key2) + return + } + if (par1 > par2) { + temp = par2 + par2 = par1 + par1 = temp + } + } + + if (par1 > npar || par2 > npar) { + call eprintf ( + "there are only %d header parameters; no action taken\n") + call pargi (npar) + par1 = 0 + par2 = -1 + } +end + + +# tu_partype -- get data type of parameter +# This routine looks for the given keyword in the header. If it is found, +# the data type (integer code) is returned as dtype. If not, dtype is set +# to the default TY_CHAR, and found is set to false. + +procedure tu_partype (tp, keyword, dtype, found) + +pointer tp # i: pointer to table descriptor +char keyword[ARB] # i: keyword name +int dtype # o: data type (TY_INT, TY_CHAR, ...) +bool found # o: true if keyword was found in header. +#-- +char kwrd[SZ_KEYWORD] # keyword returned by tbhgnp +char value[SZ_PARREC] # buffer for value of parameter +int parnum + +begin + # Get the keyword number, or zero if it isn't in the header. + call tbhfkw (tp, keyword, parnum) + + # Get the data type, ignoring the value. + if (parnum > 0) { + call tbhgnp (tp, parnum, kwrd, dtype, value) + found = true + } else { + dtype = TY_CHAR # default + found = false + } +end diff --git a/pkg/utilities/nttools/tupar/tupar.h b/pkg/utilities/nttools/tupar/tupar.h new file mode 100644 index 00000000..959fa6c1 --- /dev/null +++ b/pkg/utilities/nttools/tupar/tupar.h @@ -0,0 +1,3 @@ +define TUPAR_EXIT 1 # exit, saving changes to table +define TUPAR_QUIT 2 # quit without saving changes +define TUPAR_QUIT_NC 3 # quit, and don't ask for confirmation diff --git a/pkg/utilities/nttools/tupar/tupar.x b/pkg/utilities/nttools/tupar/tupar.x new file mode 100644 index 00000000..b4cf35e3 --- /dev/null +++ b/pkg/utilities/nttools/tupar/tupar.x @@ -0,0 +1,260 @@ +include # used to check whether I/O is redirected +include +include +include "tupar.h" # defines TUPAR_EXIT, TUPAR_QUIT + +# tupar -- edit header parameters +# This task may be used to list, add to, replace, or delete header +# parameters in a table or list of tables. +# +# Phil Hodge, 22-Jul-1987 Task created +# Phil Hodge, 11-Aug-1987 Call tbhad[] instead of tbhpt[]. +# Phil Hodge, 18-Mar-1988 Rewrite, allowing a list of tables. +# Phil Hodge, 7-Sep-1988 Change parameter name for table. +# Phil Hodge, 23-Aug-1991 Allow quit or exit. +# Phil Hodge, 9-Jul-1993 Allow quit without verification if nothing changed. +# Phil Hodge, 29-Jun-1995 Modify for FITS tables; modify tu_open and tu_close. +# Phil Hodge, 3-Oct-1995 Use tbn instead of fnt. +# Phil Hodge, 22-May-1996 Use iferr when calling tu_instr. + +define LEN_ISBUF 1000 # length or increment for instruction buffer + +procedure tupar() + +pointer tlist # for list of input table names +bool same_for_all # same set of instructions for all tables? +bool verbose # print name of each table? +bool readonly # open tables readonly? +#-- +pointer tp # pointer to table descriptor +pointer sp +pointer tname # scratch for table name +pointer tabname # scratch for full name of table (incl [...]) +pointer lbuf # scratch for input buffer +pointer isbuf # buffer for saving instructions +int bufsize # allocated size of Memc[isbuf] +int ibp # index in Memc[isbuf] +int eq_flag # exit or quit +int istat # set by tu_ex_instr; > 0 implies error +bool inplace # open tables inplace? +bool modified # true if the header was modified +bool from_stdin # get input from STDIN? +bool save_instr # save instruction in buffer? +bool iredir # is input redirected? +bool oredir # is output redirected? +bool prompt # prompt user for input? +bool alldone # done with all tables? +bool done # done with current table? +bool quit # true if we should delete temp table +bool clgetb() +int fstati() +pointer tbnopenp() +int tbnget(), tbnlen() + +begin + call smark (sp) + call salloc (tname, SZ_LINE, TY_CHAR) + call salloc (tabname, SZ_LINE, TY_CHAR) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + tlist = tbnopenp ("table") + + same_for_all = clgetb ("same") + verbose = clgetb ("verbose") + readonly = clgetb ("readonly") + if (readonly) + inplace = true + else + inplace = clgetb ("inplace") + + from_stdin = true + + # Is input or output redirected? + iredir = (fstati (STDIN, F_REDIR) == YES) + oredir = (fstati (STDOUT, F_REDIR) == YES) + prompt = !iredir # prompt if input is not redirected + + save_instr = (same_for_all && (tbnlen (tlist) > 1)) + if (save_instr) { + bufsize = LEN_ISBUF + call malloc (isbuf, bufsize, TY_CHAR) + Memc[isbuf] = EOS + } else { + bufsize = 0 + isbuf = NULL + } + + # Loop over all table names in the file name template. + alldone = (tbnget (tlist, Memc[tname], SZ_LINE) == EOF) + while (!alldone) { + + iferr { + # Open the table (or a copy of it). + call tu_open (Memc[tname], "tupar", readonly, inplace, + tp, Memc[tabname], SZ_LINE) + } then { + call eprintf ("can't open %s\n") + call pargstr (Memc[tname]) + alldone = (tbnget (tlist, Memc[tname], SZ_LINE) == EOF) + call erract (EA_WARN) + next # ignore this table + } + + if (verbose) { + if (oredir) { + call eprintf ("%s\n") + call pargstr (Memc[tabname]) + } + call printf ("%s\n") + call pargstr (Memc[tabname]) + } + + # Edit header parameters in current table. + ibp = 1 # may be incremented in loop + modified = false # may be reset within tu_instr + done = false + while ( ! done ) { + # Get an instruction, execute it, and possibly save it + # for use again. + iferr { + call tu_instr (tp, Memc[lbuf], readonly, prompt, from_stdin, + iredir, save_instr, isbuf, bufsize, ibp, + modified, eq_flag, done, istat) + } then { + call erract (EA_WARN) + } + if (istat > 0) + call eprintf ("table was opened readonly\n") + + if (inplace && !readonly && + (eq_flag == TUPAR_QUIT || eq_flag == TUPAR_QUIT_NC)) { + call eprintf ( +"can't quit without saving changes because you edited the table inplace\n") + done = false + } else if (eq_flag == TUPAR_QUIT && modified && !readonly) { + # Ask for verification before quitting. + call clputb ("go_ahead", clgetb ("quit_default")) + call eprintf ("quit without saving changes") + call flush (STDERR) + if (! clgetb ("go_ahead")) + done = false # no, don't quit + } + } + + # Reset flags after processing first table. + if (same_for_all) { + prompt = false + from_stdin = false + } + save_instr = false + + # Close the table, renaming the temp table back to the + # original if we are saving our changes. + quit = (eq_flag == TUPAR_QUIT || eq_flag == TUPAR_QUIT_NC) + iferr { + call tu_close (tp, inplace, quit, Memc[tabname]) + } then { + alldone = (tbnget (tlist, Memc[tname], SZ_LINE) == EOF) + call erract (EA_WARN) + next # ignore this table + } + + # Get the name of the next file in the list. + alldone = (tbnget (tlist, Memc[tname], SZ_LINE) == EOF) + + # If the user modified the table but then decided to quit, + # then abort without opening the rest of the tables. + if (eq_flag != TUPAR_EXIT && modified && same_for_all) + alldone = true + } + if (isbuf != NULL) + call mfree (isbuf, TY_CHAR) + call tbnclose (tlist) + call sfree (sp) +end + + +# tu_save_instr -- save edit instruction +# Save the current instruction in the instruction buffer. The entries +# are separated by '\n', and the entire set of entries is terminated +# by EOS. +# If the buffer would overflow, it will be reallocated. + +procedure tu_save_instr (lbuf, isbuf, bufsize, ibp) + +char lbuf[ARB] # i: line buffer containing instruction +pointer isbuf # io: buffer for saving instructions +int bufsize # io: current allocated size of Memc[isbuf] +int ibp # io: current index in Memc[isbuf] +#-- +int k # loop index +bool done # loop-termination flag +int leni # length of lbuf +int strlen() + +begin + leni = strlen (lbuf) + if (ibp + leni >= bufsize) { + bufsize = bufsize + LEN_ISBUF + call realloc (isbuf, bufsize, TY_CHAR) + } + + done = false + k = 1 + while ( ! done ) { + if ((lbuf[k] == EOS) || (lbuf[k] == '\n')) { + done = true + } else { + Memc[isbuf+ibp-1] = lbuf[k] + ibp = ibp + 1 + } + k = k + 1 + } + Memc[isbuf+ibp-1] = '\n' + Memc[isbuf+ibp] = EOS + ibp = ibp + 1 # so ibp points to EOS +end + + +# tu_rd_instr -- read edit instruction +# Read an instruction from the instruction buffer. When EOS is reached +# in the buffer, an EOF will be returned; otherwise, the number of char +# in the current instruction will be returned. + +int procedure tu_rd_instr (isbuf, ibp, lbuf) + +char isbuf[ARB] # i: buffer containing instructions +int ibp # io: current index in isbuf +char lbuf[ARB] # o: buffer to receive instruction +#-- +int k # loop index +bool done # loop-termination flag + +begin + done = false + k = 0 + while ( ! done ) { + + if (isbuf[ibp] == '\n') { + + if (k > 0) # skip past adjacent '\n' + done = true + ibp = ibp + 1 + + } else if (isbuf[ibp] == EOS) { + + done = true # leave ibp pointing to EOS + + } else { + + k = k + 1 + lbuf[k] = isbuf[ibp] + ibp = ibp + 1 + } + } + lbuf[k+1] = EOS + + if (k <= 0) + k = EOF + return (k) +end diff --git a/pkg/utilities/nttools/x_nttools.x b/pkg/utilities/nttools/x_nttools.x new file mode 100644 index 00000000..5fe2c2c7 --- /dev/null +++ b/pkg/utilities/nttools/x_nttools.x @@ -0,0 +1,50 @@ +task taextract, + tainsert, + keypar = t_keypar, + keytab = t_keytab, + gtedit = t_gtedit, + parkey = t_parkey, + partab = t_partab, + tabkey = t_tabkey, + tabpar = t_tabpar, + imtab, + tabim, + tcalc = t_tcalc, + tchcol, + tcheck, + tchsize, + tcopy, + tcreate, + tdelete, + tdiffer = t_tdiffer, + tdump, + tedit = t_tedit, + texpand, + thedit = t_thedit, + thistogram, + thselect = t_thselect, + tinfo, + tintegrate = t_tintegrate, + tjoin = t_tjoin, + tlcol, + tlinear, + tmatch, + tmerge, + tprint, + tproduct = t_product, + tproject = t_project, + tquery = t_tquery, + tread = t_tread, + trebin, + tselect = t_tselect, + tsort = t_tsort, + tstat, + ttranspose, + tunits, + tupar, + tscopy = t_tcopy, + txtable = t_txtable, + tximage = t_tximage, + titable = t_titable, + tiimage = t_tiimage + diff --git a/pkg/utilities/nttools/zz.xml b/pkg/utilities/nttools/zz.xml new file mode 100644 index 00000000..59005749 --- /dev/null +++ b/pkg/utilities/nttools/zz.xml @@ -0,0 +1,3427 @@ + + + + + +Chandra Source Catalog VO Cone Search Service + + + ICRS Coordinate System + + + + + + + + + + + + + + ICRS coordinates + + + + + + +Source name in the format 'CXO Jhhmmss.s +/- ddmmss' + + +Source position, ICRS right ascension + + +Source position, ICRS declination + + +Major radius of the 95% confidence level error ellipse + + +Source regions overlap (source is confused) + + +Deconvolved source extent is inconsistent with a point source at the 90% confidence level + + +Source is saturated in all observations; source properties are unreliable + + +Aperture-corrected net energy flux inferred from the source region aperture, calculated by counting X-ray events; ACIS broad energy band + + +Aperture-corrected net energy flux inferred from the source region aperture, calculated by counting X-ray events (68% lower confidence limit); ACIS broad energy band + + +Aperture-corrected net energy flux inferred from the source region aperture, calculated by counting X-ray events (68% upper confidence limit); ACIS broad energy band + + +Aperture-corrected net energy flux inferred from the source region aperture, calculated by counting X-ray events; HRC wide energy band + + +Aperture-corrected net energy flux inferred from the source region aperture, calculated by counting X-ray events (68% lower confidence limit); HRC wide energy band + + +Aperture-corrected net energy flux inferred from the source region aperture, calculated by counting X-ray events (68% upper confidence limit); HRC wide energy band + + +Highest source flux significance across all observations + + +Spectral hardness ratio measured between ACIS energy bands 'h' and 'm'; hard_hm = (flux_aper_h - flux_aper_m)/flux_aper_b + + +Spectral hardness ratio measured between ACIS energy bands 'h' and 'm'; hard_hm = (flux_aper_h - flux_aper_m)/flux_aper_b (68% lower confidence limit) + + +Spectral hardness ratio measured between ACIS energy bands 'h' and 'm'; hard_hm = (flux_aper_h - flux_aper_m)/flux_aper_b (68% upper confidence limit) + + +Spectral hardness ratio measured between ACIS energy bands 'm' and 's'; hard_ms = (flux_aper_m - flux_aper_s)/flux_aper_b + + +Spectral hardness ratio measured between ACIS energy bands 'm' and 's'; hard_ms = (flux_aper_m - flux_aper_s)/flux_aper_b (68% lower confidence limit) + + +Spectral hardness ratio measured between ACIS energy bands 'm' and 's'; hard_ms = (flux_aper_m - flux_aper_s)/flux_aper_b (68% upper confidence limit) + + +Intra-observation Gregory-Loredo variability index in the range [0, 10] (highest value across all observations); ACIS broad energy band + + + +Intra-observation Gregory-Loredo variability index in the range [0, 10] (highest value across all observations); HRC wide energy band + + + +Inter-observation variability index in the range [0, 10]; indicates whether the source region photon flux is constant between observations; ACIS broad energy band + + + +Inter-observation variability index in the range [0, 10]; indicates whether the source region photon flux is constant between observations; HRC wide energy band + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
CXO J053513.4-05234083.80601567-5.394484310.14563FFF6.97894E-146.85624E-147.10287E-145.88765E-145.56953E-146.20898E-1425.9701-0.0822159-0.103467-0.0608849-0.33969-0.370832-0.3084761008-32768
CXO J053513.5-05233083.80637907-5.391853040.14712TFF6.78161E-146.65089E-146.91366E-143.03441E-142.80268E-143.26849E-1428.58080.0105262-0.01092290.0322564-0.326373-0.353819-0.2991481008-32768
CXO J053513.9-05231983.80801443-5.38886030.21491FFF5.27045E-154.80761E-155.73796E-1511.0835-0.161814-0.22216-0.103899-0.290804-0.363042-0.218092-327686-32768
CXO J053514.0-05233883.8085595-5.39395770.14728FFF5.66661E-145.54982E-145.78459E-142.97063E-142.74026E-143.20332E-1430.9082-0.0350682-0.0573876-0.0129662-0.176479-0.203986-0.1490031078-32768
CXO J053514.2-05230483.80953052-5.384448890.15885FFF5.45327E-145.33644E-145.57128E-1424.40250.910490.8950180.9253680.04111190.03364840.04886129-327688-32768
CXO J053514.3-05230883.80962741-5.385577120.14858FTF6.64955E-146.54639E-146.75375E-141.05285E-149.11164E-151.19597E-1445.27560.3541990.335610.3725530.1954980.1823120.2082921008-32768
CXO J053514.3-05231783.80969326-5.388109810.16924TFF2.56431E-142.47535E-142.65417E-1417.40340.9851710.9785430.990966-0.00698975-0.0128563-0.002142129-327688-32768
CXO J053514.3-05225383.8098206-5.38164070.16466FTF2.05176E-141.98107E-142.12316E-1415.06490.5609340.5111230.6096980.2108210.1862940.2357788-327688-32768
CXO J053514.4-05232283.8099784-5.389665680.23553FFF4.66587E-154.28105E-155.05458E-1512.1756-0.0756736-0.135332-0.0170884-0.114952-0.183403-0.04508149-327688-32768
CXO J053514.3-05233383.80998065-5.392611560.14702FFF4.8023E-144.70178E-144.90384E-141.46049E-141.29563E-141.62703E-1427.6562-0.0825775-0.106809-0.0578608-0.124551-0.156265-0.092763908-32768
CXO J053514.5-05231583.81056936-5.387722330.17135TFF1.34289E-141.27463E-141.41184E-148.55561E-157.21816E-159.90657E-1512.0550.980620.9721170.987105-0.00429089-0.00957531-3.08654E-4297-32768
CXO J053514.5-05240783.81072267-5.402171190.2283TFF9.1153E-158.44146E-159.79595E-158.85950.9681810.951850.981924-0.00693137-0.01839430.002083141-327686-32768
CXO J053514.6-05232883.81100284-5.391226470.43437TFF3.78192E-153.14545E-154.42482E-155.92101-0.0631104-0.1776370.0523516-0.190031-0.324285-0.05577976-32768-32768-32768
CXO J053514.6-05230183.81109487-5.383790190.14849TTF7.39896E-147.29582E-147.50313E-149.53745E-158.13605E-151.0953E-1465.31240.1704920.1570440.1838820.1804090.169150.1915441008-32768
CXO J053514.6-05224983.81120139-5.380331760.18087FTF1.32936E-141.2721E-141.38719E-1413.95850.489440.4330170.5441770.2354060.2062460.26487-327687-32768
CXO J053514.7-05241283.81128448-5.403433550.19978TFF7.71247E-157.15899E-158.27154E-156.149470.3705670.2594660.47732-0.138487-0.2424-0.03476548-327685-32768
CXO J053514.7-05232283.81133486-5.389640170.14839TFF5.01776E-144.92056E-145.11593E-145.23879E-144.93591E-145.54472E-1429.55090.282670.2519080.3129920.2894080.2713140.3076821098-32768
CXO J053514.8-05240683.81170941-5.401853590.20687TFF1.95425E-141.8482E-142.06138E-1410.04250.9723710.959990.9833110.00443213-0.00117690.01082829-327688-32768
CXO J053514.8-05234683.8117676-5.396156710.15213TFF1.9664E-141.88916E-142.04442E-141.26507E-141.10556E-141.4262E-1412.2048-0.16864-0.213904-0.123749-0.213757-0.285474-0.140922805-32768
CXO J053514.8-05231583.81177012-5.387708690.17193TTF9.85838E-159.45421E-151.02666E-1415.2939-0.126347-0.166511-0.0858136-0.278406-0.332037-0.2237332-327686-32768
CXO J053514.8-05230483.81193361-5.384664250.17267TTF2.03975E-141.97508E-142.10508E-1420.24470.3173450.273840.3600550.2835140.2577430.3097278-327688-32768
CXO J053514.9-05241283.81217858-5.403510210.14801TFF5.3239E-145.22719E-145.4216E-141.58719E-141.41828E-141.75781E-1434.75230.04651750.02569840.0675352-0.107479-0.131671-0.08358841018-32768
CXO J053514.9-05232883.81220892-5.391332750.16083TTF4.68217E-154.2982E-155.07002E-153.58725E-152.70965E-154.46036E-157.89055-0.254059-0.369787-0.1397280.3698020.2576630.481755106-32768
CXO J053514.9-05233883.81228445-5.394169690.14232FFF1.49754E-131.48202E-131.51322E-132.82477E-132.75562E-132.89463E-1354.1441-0.0472355-0.0585613-0.0359605-0.150355-0.16636-0.1342271068-32768
CXO J053515.0-05235483.81265915-5.398419060.59443FFF3.93214E-152.99955E-154.86489E-154.16316-327682-32768-32768
CXO J053515.1-05230483.81297046-5.384515690.45384TFF1.88649E-159.06494E-162.8637E-153.053280.837230.7158030.933967-0.0320696-0.1187980.02930790-32768-32768-32768
CXO J053515.1-05234683.81314399-5.396215120.2003TFF4.39873E-153.92166E-154.88063E-154.00059E-153.0109E-154.9949E-155.6963-0.0285843-0.1028980.0406812-0.249534-0.381015-0.102094600-32768
CXO J053515.1-05225483.81329418-5.381724730.14462TFF1.64113E-131.62452E-131.65791E-131.6316E-141.43274E-141.83248E-1452.08920.4508760.4369260.4649470.1377640.1269990.1482641008-32768
CXO J053515.1-05231883.81330006-5.38854080.47766FTF3.49507E-152.3225E-154.65674E-153.821590.8547490.7530110.937876-0.0355204-0.1156130.02243680-32768-32768-32768
CXO J053515.2-05225683.81360368-5.382422180.1999TTF1.03202E-121.02837E-121.03571E-122.6702E-132.60158E-132.73951E-13130.5220.07047770.06444880.0764034-0.0717052-0.0779943-0.06552731008-32768
CXO J053515.3-05233383.81407441-5.392552720.14553TFF2.25803E-142.19797E-142.31869E-141.93736E-141.7427E-142.134E-1420.1199-0.137472-0.170874-0.103627-0.149193-0.192213-0.105697928-32768
CXO J053515.4-05234583.81434295-5.395906450.14712TFF5.51555E-145.41834E-145.61375E-149.9547E-158.51468E-151.14093E-1442.41070.08624150.07128330.10104-0.00267428-0.02186730.01664361008-32768
CXO J053515.4-05224883.8145085-5.380115040.14676TTF1.04415E-131.03206E-131.05635E-138.82286E-157.076E-151.05874E-1441.8304-0.0174547-0.03541588.28379E-4-0.0411823-0.0614385-0.02098211008-32768
CXO J053515.4-05233783.81455127-5.393761290.45111TFF1.41203E-159.77813E-161.84263E-154.3122-0.0434585-0.2293190.1404490.184190.002170750.3672311-32768-32768-32768
CXO J053515.5-05224683.81473478-5.379482930.31051TTF1.67177E-141.5583E-141.78639E-1412.19930.9376940.9103390.9633170.0114968-0.003999620.02686778-327687-32768
CXO J053515.6-05240283.81504651-5.400787930.15306FFF1.91504E-141.83643E-141.99445E-145.66629E-145.35161E-145.98415E-1417.7872-0.178473-0.224961-0.131402-0.295806-0.362798-0.227692597-32768
CXO J053515.6-05225683.81514589-5.38230260.1784FTF8.55289E-138.52034E-138.58577E-132.02006E-122.00158E-122.03873E-12129.7320.06120330.05515430.06729-0.0245866-0.0308778-0.01828081088-32768
CXO J053515.7-05233983.815411-5.39418110.39841TTF2.05992E-141.74398E-142.37906E-146.298740.6071130.5002760.7077730.1608630.1060580.2192750-32768-32768-32768
CXO J053515.7-05241183.81562914-5.4032036400000010.642673FFF3.80835E-162.06299E-165.56111E-163.93135-0.147377-0.27926-0.0136489-0.32344-0.508552-0.1290116-32768-32768-32768
CXO J053515.7-05233883.8157219-5.393905520.45063TTF3.18339E-142.77075E-143.60019E-147.274520.8226390.754310.886820.05256130.01510420.0905968-32768-32768-32768
CXO J053515.7-05230983.81574739-5.386068320.40301TTF3.03573E-123.029E-123.04254E-121.87491E-121.85709E-121.89291E-12202.7380.2745770.2708270.27825-0.0459597-0.0495455-0.0423645808-32768
CXO J053515.8-05230583.81588895-5.384850940.48598TFF9.31635E-158.2033E-151.04407E-149.11467-0.137899-0.205363-0.0699988-0.283179-0.370767-0.1910452-32768-32768-32768
CXO J053515.8-05231383.815963-5.387269780.40057TTF2.77082E-122.76452E-122.77719E-121.01992E-121.00666E-121.0333E-12197.5730.2593730.2554830.263164-0.04572-0.0494406-0.0419462908-32768
CXO J053515.8-05224583.81598875-5.379342370.15512TTF1.5406E-141.492E-141.5897E-143.40691E-152.32026E-154.49824E-1521.9792-0.0994224-0.130616-0.0679763-0.14147-0.181277-0.10211008-32768
CXO J053515.8-05232283.81610029-5.389536890.43705FFF1.97845E-141.67432E-142.28564E-145.331780.6443250.5233450.765435-0.140958-0.260161-0.02207170-32768-32768-32768
CXO J053515.8-05231883.81611207-5.388564860.44418TFF1.13066E-149.23675E-151.33974E-145.95239-0.0905449-0.1795065.26605E-4-0.431631-0.554358-0.3042640-32768-32768-32768
CXO J053515.8-05230183.81612461-5.383826110.23917FFF8.45856E-157.64832E-159.277E-157.90999-0.0861684-0.170009-0.00161331-0.158934-0.263449-0.04897870-327685-32768
CXO J053515.8-05223383.81613303-5.375850420.37078FFF1.7933E-151.4194E-152.16863E-155.23268-0.474765-0.592407-0.3543120.2604580.1023380.4173318-327685-32768
CXO J053515.8-05231083.81619-5.38630280.48816TTF4.64943E-134.5283E-134.77179E-1337.3210.2481120.2260140.270410.1358020.1177040.1536399-32768-32768-32768
CXO J053515.9-05241783.8162912-5.404918450.6885FFF3.78186E-152.91713E-154.65E-154.3122-327682-32768-32768
CXO J053515.9-05234983.81647584-5.397132680.14102TTF3.87473E-133.85092E-133.89878E-131.89669E-131.83958E-131.95437E-1373.52940.06420110.06295230.06545310.02228160.01116470.03332331078-32768
CXO J053516.0-05235283.81675305-5.398013650.14462TTF1.00513E-139.911E-141.0193E-131.48552E-141.31388E-141.65889E-1435.66260.1577340.1350770.1801050.04367720.02217740.06521251018-32768
CXO J053516.0-05225383.81698406-5.381644260.16235FFF3.26789E-143.18198E-143.35468E-1425.14920.8655710.8466840.8835930.06549860.0563930.07499129-327688-32768
CXO J053516.0-05230683.81701311-5.385221350.14238TTF1.76855E-131.75356E-131.7837E-135.32069E-144.98546E-145.65931E-1468.69430.06384250.05291150.0748212-0.0784673-0.0903596-0.06631971008-32768
CXO J053516.0-05232583.8170161-5.390400070.42036TTF1.00543E-149.06073E-151.10579E-1411.0945-0.125453-0.17706-0.0731745-0.344981-0.416858-0.2726620-32768-32768-32768
CXO J053516.0-05241183.8170323-5.40311780.18202FFF2.25929E-142.13907E-142.38072E-143.44264E-152.59187E-154.29976E-1512.9669-0.0641377-0.121644-0.00538426-0.016818-0.08418430.0495484728-32768
CXO J053516.0-05232283.81705333-5.38966350.1439TTF8.06604E-147.93614E-148.19725E-149.51118E-156.51756E-151.25222E-1435.91280.5750930.556270.594211-0.0963508-0.113819-0.0786152808-32768
CXO J053516.1-05231383.81720052-5.387088750.29045TFF1.17102E-141.06569E-141.27741E-146.713410.1791130.09075050.272076-0.316139-0.42591-0.2033087-327680-32768
CXO J053516.1-05230983.8172558-5.385986550.44726TTF3.83267E-152.89841E-154.77108E-153.4279-0.0114393-0.2001160.16813-0.0802978-0.3103410.1738810-32768-32768-32768
CXO J053516.1-05223783.81744498-5.377021050.16304FFF1.24777E-141.20505E-141.29091E-143.88118E-152.96665E-154.78877E-1515.55030.08887850.03592650.1414310.1099170.05870910.16105708-32768
CXO J053516.2-05231883.81746865-5.388547140.29102TTF1.7293E-141.62498E-141.83469E-1411.8731-0.0821205-0.134065-0.0290845-0.217927-0.288334-0.1446486-327684-32768
CXO J053516.2-05231683.8178479-5.387863850.15414TTF3.32569E-143.24069E-143.41155E-1416.95680.2141850.1715840.256628-0.0273673-0.07456240.02074589-327688-32768
CXO J053516.3-05240383.81822268-5.400864820.14238TFF5.65119E-135.60431E-135.69854E-131.1893E-131.14403E-131.23504E-1366.14610.1204210.1080760.1329240.05653060.04456260.0685104808-32768
CXO J053516.4-05232983.81859564-5.391421350.43656FFF1.33598E-141.16336E-141.51034E-148.24052-0.107666-0.166067-0.0482851-0.560076-0.642993-0.4750820-32768-32768-32768
CXO J053516.4-05233183.81861877-5.392001980.4145TTF4.70839E-153.72184E-155.70217E-153.954510.10125-0.04738530.247861-0.213178-0.403455-0.007613780-32768-32768-32768
CXO J053516.4-05232283.81863682-5.389643950.16555TTF3.15953E-123.15334E-123.16578E-121.93706E-111.93136E-111.94281E-11335.79-0.0574404-0.0603554-0.054598-0.179857-0.183533-0.176244708-32768
CXO J053516.4-05225683.81868061-5.382314380.25375FFF9.13394E-158.46442E-159.81021E-1510.10850.5325910.4602160.6035360.2199550.1839530.2568898-327688-32768
CXO J053516.4-05223483.81869862-5.376372810.16109TFF1.71057E-141.66378E-141.75782E-143.92169E-152.98105E-154.87032E-1523.0625-0.110707-0.140501-0.0809267-0.146559-0.184692-0.1075921008-32768
CXO J053516.5-05240583.81907688-5.401607150.14862TFF6.17377E-146.00346E-146.34581E-142.21828E-142.01516E-142.42345E-1420.473-0.0114133-0.04820040.0240581-0.0682099-0.110431-0.0262589908-32768
CXO J053516.6-05231583.81916799-5.387719410.2965TTF2.38905E-142.24716E-142.53237E-1411.23430.4593880.3942760.524993-0.0552914-0.124190.01786396-327686-32768
CXO J053516.7-05223183.81971948-5.375297560.15804TFF5.06851E-144.98874E-145.14908E-145.06829E-154.00493E-156.13022E-1544.56360.03107840.01498520.0471353-0.0098311-0.02873030.009040381018-32768
CXO J053516.7-05231683.81979918-5.387833230.15457TTF5.41387E-145.31441E-145.51433E-1442.00050.343890.3244760.3632420.1374740.1201540.15502610-327688-32768
CXO J053516.7-05232783.81985651-5.391061850.15396TTF3.1808E-143.10464E-143.25773E-1419.3821-0.173608-0.219488-0.1283080.3530160.309270.3970480-327687-32768
CXO J053516.7-05240483.81985811-5.401120960.14189TTF6.14592E-136.09573E-136.19661E-131.20933E-131.16357E-131.25557E-1362.35060.0766460.06429060.0891912-0.0215484-0.0345894-0.00835781018-32768
CXO J053516.9-05224883.82067804-5.380036020.26011TFF3.40385E-153.02903E-153.78245E-156.5724-0.209941-0.311983-0.1061490.208570.09926210.3155036-327680-32768
CXO J053516.9-05230083.82072056-5.383544430.1809FTF4.38438E-153.98639E-154.7864E-152.73814E-151.91129E-153.55782E-158.924460.0812748-0.02006440.1810620.3042170.245670.364153626-32768
CXO J053516.9-05233683.82074477-5.393578580.1656TFF6.65737E-156.25524E-157.06356E-159.300350.3790740.286050.4702260.1182460.02878470.2053747-327686-32768
CXO J053517.0-05223283.82085444-5.375792420.14172TTF5.12055E-135.09571E-135.14564E-131.51166E-131.46086E-131.56297E-13104.4610.04190940.03474950.0490269-0.0550702-0.0631752-0.04713081008-32768
CXO J053517.0-05233983.82106838-5.394322940.14281TFF6.18657E-146.09481E-146.27926E-141.1665E-131.1214E-131.21206E-1332.3985-0.0297006-0.0531671-0.00677787-0.0486834-0.0749776-0.022494510106-32768
CXO J053517.0-05233383.82109826-5.392738150.1631TTF1.02987E-121.02531E-121.03447E-128.75803E-148.36184E-149.15822E-14127.4990.6308090.6252370.6363340.1649650.1618630.1680621008-32768
CXO J053517.1-05224983.82131869-5.380532610.19466TFF4.86951E-154.52284E-155.21969E-153.98751E-153.07147E-154.89601E-1512.7202-0.143314-0.192783-0.0933213-0.259469-0.324615-0.193064717-32768
CXO J053517.2-05231683.82189417-5.387890010.14245FTF5.88682E-145.81311E-145.96127E-148.88455E-148.48444E-149.2887E-1438.8741-0.106269-0.113609-0.0990529-0.77797-0.792073-0.76355000-32768
CXO J053517.2-05242383.82196154-5.406661650.21976FFF2.62389E-152.3843E-152.8659E-157.6888-0.19058-0.261001-0.121977-0.414758-0.517638-0.3089097-327685-32768
CXO J053517.3-05223583.82228078-5.376539420.20984TFF5.84579E-155.32199E-156.37489E-157.458950.6994690.6074030.7895280.1142610.06564620.1627438-327685-32768
CXO J053517.3-05224583.82234198-5.379312170.22014TFF6.80224E-156.2389E-157.37126E-156.67030.3966090.2827380.507870.2689180.2099310.3290878-327685-32768
CXO J053517.3-05230483.82237467-5.384617450.42463FFF9.77684E-158.70144E-151.08631E-149.49126-0.0447789-0.1439270.05211080.3941110.3114050.476199-32768-32768-32768
CXO J053517.3-05240083.8224061-5.400022110.18139FFF1.85293E-141.74155E-141.96543E-143.45141E-152.58232E-154.31257E-159.242790.7554740.6954030.8103550.09393390.06617190.1257815-32768
CXO J053517.3-05241383.82244801-5.403813310.19226TFF4.69414E-154.36344E-155.02817E-152.84905E-152.06367E-153.63713E-157.67701-0.186065-0.262651-0.104858-0.0730942-0.1731020.029691210-32768
CXO J053517.4-05232083.82275909-5.389137780.14305TFF6.19418E-146.10112E-146.28819E-149.46104E-149.05153E-149.87468E-1433.9473-0.120336-0.139946-0.100275-0.173029-0.198721-0.147012828-32768
CXO J053517.4-05225183.82278772-5.380856180.26154FFF1.59443E-141.48174E-141.70825E-1410.32170.9678240.9484240.983472-0.0020122-0.01290.0077893210-327680-32768
CXO J053517.4-05241783.8228207-5.404766430.17747TFF6.73012E-156.40928E-157.0542E-1512.4071-0.134308-0.178341-0.0910805-0.39546-0.458828-0.3325257-327686-32768
CXO J053517.5-05225683.82316819-5.382397640.15331FTF2.83102E-142.76496E-142.89775E-147.30177E-156.08289E-158.53297E-1522.53820.2105740.1749350.2454330.0311087-0.002876640.06574811018-32768
CXO J053517.7-05223083.82394082-5.375175470.492273FFF2.57352E-152.04402E-153.10329E-154.979050.4351060.2905640.5734090.1667670.06405620.2651732-32768-32768-32768
CXO J053517.7-05234283.82403421-5.395072420.2641TTF2.22294E-142.09875E-142.34839E-1414.64980.3939850.3360880.4508330.2368580.2057780.2685048-327688-32768
CXO J053517.7-05234483.82408397-5.395568380.15493TTF4.40876E-144.30497E-144.5136E-146.16894E-155.06292E-157.28614E-1524.0684-0.0935179-0.125494-0.06166430.012234-0.02494150.0495115918-32768
CXO J053517.8-05231583.82422327-5.387610970.14969TTF2.14931E-142.09499E-142.20418E-145.5013E-154.37611E-156.62636E-1521.7772-0.0485423-0.0781495-0.0186874-0.238534-0.27681-0.200386908-32768
CXO J053517.8-05230283.82443905-5.384140230.15408FFF2.47255E-142.41076E-142.53496E-143.99183E-153.06073E-154.9291E-1519.7450.0294182-0.01209830.07060360.1527620.1115780.19379806-32768
CXO J053517.9-05224583.82479363-5.379299550.40131TTF2.34246E-122.33673E-122.34825E-127.72945E-137.61515E-137.8449E-13192.1130.1766570.1726920.180645-0.017412-0.021351-0.01341551008-32768
CXO J053517.9-05233583.82483373-5.393116990.159TFF5.0092E-154.57792E-155.44484E-156.66509E-155.48228E-157.85984E-157.34797-0.194774-0.261407-0.128891-0.309379-0.418885-0.197315000-32768
CXO J053517.9-05224083.82493994-5.377993850.46551TTF4.98307E-154.215E-155.75889E-156.088870.0498089-0.04374020.140453-0.46677-0.579925-0.3510989-32768-32768-32768
CXO J053518.0-05240283.82516072-5.400818540.15291TTF4.64651E-144.5185E-144.77582E-147.56507E-156.29819E-158.84474E-1517.8490.3365570.2868510.3853790.2526720.2247120.280702908-32768
CXO J053518.0-05240083.82528688-5.400271070.14991TTF4.04349E-143.94916E-144.13877E-141.52375E-141.35145E-141.6978E-1429.5094-0.0313176-0.0572702-0.00540553-0.028688-0.0578774.73572E-4908-32768
CXO J053518.2-05233583.82583666-5.393249910.14673TFF6.27032E-146.15475E-146.38706E-141.45277E-141.28904E-141.61815E-1440.86340.3390680.3194490.3584840.06820790.05232780.08397311008-32768
CXO J053518.2-05231583.82596286-5.387602670.34924FFF2.1647E-151.51151E-152.81364E-153.55219-0.0952553-0.2195410.0294111-0.273004-0.45569-0.0662922-327685-32768
CXO J053518.3-05224183.82636223-5.378149580.52516TFF4.78337E-154.06288E-155.51113E-156.91727-0.01251-0.09984480.0765684-0.32761-0.437286-0.2132640-32768-32768-32768
CXO J053518.3-05240483.82637823-5.401300880.15454TFF1.50312E-141.4616E-141.54506E-149.74068E-158.39717E-151.10978E-1418.2882-0.0170644-0.04512440.0113308-0.496462-0.534808-0.4579241026-32768
CXO J053518.3-05223783.82655004-5.377070750.4015TTF1.51757E-121.51311E-121.52209E-124.8168E-134.72606E-134.90845E-13156.0290.08171650.07667810.0867794-0.0223465-0.02765-0.01711891098-32768
CXO J053518.4-05240683.82694247-5.401912650.16124TTF1.37515E-141.33676E-141.41392E-142.62695E-151.92102E-153.45326E-1520.2619-0.147293-0.177667-0.116693-0.254688-0.297129-0.212164928-32768
CXO J053518.5-05232983.82710603-5.391395440.29924FFF3.55482E-153.07533E-154.03916E-155.196010.0224992-0.08852410.1335070.0140313-0.1004490.132519-327680-32768
CXO J053518.6-05231383.82775602-5.38714750.1553FFF5.06073E-144.95229E-145.17026E-142.48157E-151.74615E-153.21853E-1520.30470.7112470.6809130.7405750.09778370.08229360.113861818-32768
CXO J053518.7-05225683.82792335-5.382410030.14563FTF8.38129E-148.2714E-148.49229E-142.00977E-141.81923E-142.20222E-1440.73870.05723740.036320.07792740.1563190.1364810.1758571068-32768
CXO J053518.8-05230683.8285511-5.385206880.38307TFF3.13434E-152.6248E-153.64903E-154.100980.5170240.3874920.6478820.1362210.04525470.2230877-327683-32768
CXO J053518.8-05232883.82863504-5.391309350.18426TFF7.80936E-157.34268E-158.28074E-153.41606E-152.54272E-154.2936E-1513.50890.1483360.08621140.2091090.1169380.06065270.17337807-32768
CXO J053518.8-05241783.82870493-5.404799450.2054FFF2.02885E-151.8429E-152.21669E-152.54071E-151.81143E-153.27084E-157.47107-0.111318-0.206769-0.0157024-0.105823-0.2175570.0062841715-32768
CXO J053518.9-05232183.82900851-5.389388790.18377FFF6.29657E-155.91494E-156.68206E-153.93679E-153.03809E-154.84281E-159.75966-0.197391-0.257914-0.136809-0.0810207-0.1735160.0124436827-32768
CXO J053519.0-05234983.82943179-5.397077450.18362TFF1.26527E-141.19883E-141.33238E-142.50362E-151.77341E-153.23775E-159.537040.5254230.461240.5880780.05526250.01680230.0953571305-32768
CXO J053519.0-05230783.82947555-5.385385530.60007TFF3.06568E-152.35388E-153.77334E-153.372580.5517880.3641720.7309360.0525947-0.07883570.1807341-32768-32768-32768
CXO J053519.1-05232683.82965729-5.390792190.149TFF4.70476E-144.6041E-144.80644E-143.13813E-142.90203E-143.37661E-1429.1204-0.0186874-0.04554050.008320420.0217701-0.007979790.05139391008-32768
CXO J053519.2-05225083.83003508-5.380692480.14563FTF7.71165E-147.6122E-147.8121E-142.18413E-141.98589E-142.38437E-1435.18450.0103539-0.01239920.0334530.06222180.038350.0862733808-32768
CXO J053519.3-05230683.83073658-5.385086420.20406TFF3.86105E-153.52179E-154.20375E-151.51947E-141.35327E-141.68735E-149.031090.708850.647330.7628360.1186350.08998350.149562825-32768
CXO J053519.6-05235783.83170407-5.39920850.14599FFF5.65477E-145.57404E-145.73631E-141.58911E-141.41853E-141.76143E-1433.2056-0.0563964-0.0777684-0.0345916-0.0881097-0.114265-0.06163211008-32768
CXO J053519.6-05230383.83180325-5.384295030.28673TFF3.38795E-143.25298E-143.52428E-1424.19230.5219230.4900190.5529170.1681570.1480410.18761710-327688-32768
CXO J053520.1-05230883.83405767-5.385651340.17176FFF1.6732E-141.60671E-141.74036E-148.91914E-157.62577E-151.02256E-1416.73780.7048720.6676550.740770.08029040.05641530.103995988-32768
CXO J053520.4-05232983.83524928-5.391579150.14495FTF1.48294E-131.46302E-131.50305E-136.19981E-145.87156E-146.53138E-1437.6376-0.0342289-0.0543452-0.0144118-0.0400774-0.0630867-0.01710711008-32768
CXO J053520.6-05235383.83613982-5.398070620.14505FFF1.22974E-131.21659E-131.24301E-133.53667E-143.28387E-143.79203E-1451.6767-0.0736723-0.0873284-0.0601008-0.114096-0.131036-0.09706451088-32768
CXO J053520.9-05232183.83713079-5.389376130.17294FFF1.27352E-141.22038E-141.32719E-144.79489E-153.76627E-155.82531E-1515.092-0.00451392-0.05067690.0414142-0.143189-0.198027-0.0872535917-32768
CXO J053521.0-05234883.83769663-5.396902990.16319FTF9.62079E-139.58324E-139.65871E-134.11609E-134.032E-134.20101E-13120.3810.02733040.02113110.0335637-0.0775369-0.0845064-0.0706931058-32768
+ + diff --git a/pkg/utilities/nttools/zz_bad.xml b/pkg/utilities/nttools/zz_bad.xml new file mode 100644 index 00000000..def62363 --- /dev/null +++ b/pkg/utilities/nttools/zz_bad.xml @@ -0,0 +1,3427 @@ + + + + + +Chandra Source Catalog VO Cone Search Service + + + ICRS Coordinate System + + + + + + + + + + + + + + ICRS coordinates + + + + + + +Source name in the format 'CXO Jhhmmss.s +/- ddmmss' + + +Source position, ICRS right ascension + + +Source position, ICRS declination + + +Major radius of the 95% confidence level error ellipse + + +Source regions overlap (source is confused) + + +Deconvolved source extent is inconsistent with a point source at the 90% confidence level + + +Source is saturated in all observations; source properties are unreliable + + +Aperture-corrected net energy flux inferred from the source region aperture, calculated by counting X-ray events; ACIS broad energy band + + +Aperture-corrected net energy flux inferred from the source region aperture, calculated by counting X-ray events (68% lower confidence limit); ACIS broad energy band + + +Aperture-corrected net energy flux inferred from the source region aperture, calculated by counting X-ray events (68% upper confidence limit); ACIS broad energy band + + +Aperture-corrected net energy flux inferred from the source region aperture, calculated by counting X-ray events; HRC wide energy band + + +Aperture-corrected net energy flux inferred from the source region aperture, calculated by counting X-ray events (68% lower confidence limit); HRC wide energy band + + +Aperture-corrected net energy flux inferred from the source region aperture, calculated by counting X-ray events (68% upper confidence limit); HRC wide energy band + + +Highest source flux significance across all observations + + +Spectral hardness ratio measured between ACIS energy bands 'h' and 'm'; hard_hm = (flux_aper_h - flux_aper_m)/flux_aper_b + + +Spectral hardness ratio measured between ACIS energy bands 'h' and 'm'; hard_hm = (flux_aper_h - flux_aper_m)/flux_aper_b (68% lower confidence limit) + + +Spectral hardness ratio measured between ACIS energy bands 'h' and 'm'; hard_hm = (flux_aper_h - flux_aper_m)/flux_aper_b (68% upper confidence limit) + + +Spectral hardness ratio measured between ACIS energy bands 'm' and 's'; hard_ms = (flux_aper_m - flux_aper_s)/flux_aper_b + + +Spectral hardness ratio measured between ACIS energy bands 'm' and 's'; hard_ms = (flux_aper_m - flux_aper_s)/flux_aper_b (68% lower confidence limit) + + +Spectral hardness ratio measured between ACIS energy bands 'm' and 's'; hard_ms = (flux_aper_m - flux_aper_s)/flux_aper_b (68% upper confidence limit) + + +Intra-observation Gregory-Loredo variability index in the range [0, 10] (highest value across all observations); ACIS broad energy band + + + +Intra-observation Gregory-Loredo variability index in the range [0, 10] (highest value across all observations); HRC wide energy band + + + +Inter-observation variability index in the range [0, 10]; indicates whether the source region photon flux is constant between observations; ACIS broad energy band + + + +Inter-observation variability index in the range [0, 10]; indicates whether the source region photon flux is constant between observations; HRC wide energy band + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
CXO J053513.4-05234083.80601567-5.394484310.14563FFF6.97894E-146.85624E-147.10287E-145.88765E-145.56953E-146.20898E-1425.9701-0.0822159-0.103467-0.0608849-0.33969-0.370832-0.3084761008-32768
CXO J053513.5-05233083.80637907-5.391853040.14712TFF6.78161E-146.65089E-146.91366E-143.03441E-142.80268E-143.26849E-1428.58080.0105262-0.01092290.0322564-0.326373-0.353819-0.2991481008-32768
CXO J053513.9-05231983.80801443-5.38886030.21491FFF5.27045E-154.80761E-155.73796E-1511.0835-0.161814-0.22216-0.103899-0.290804-0.363042-0.218092-327686-32768
CXO J053514.0-05233883.8085595-5.39395770.14728FFF5.66661E-145.54982E-145.78459E-142.97063E-142.74026E-143.20332E-1430.9082-0.0350682-0.0573876-0.0129662-0.176479-0.203986-0.1490031078-32768
CXO J053514.2-05230483.80953052-5.384448890.15885FFF5.45327E-145.33644E-145.57128E-1424.40250.910490.8950180.9253680.04111190.03364840.04886129-327688-32768
CXO J053514.3-05230883.80962741-5.385577120.14858FTF6.64955E-146.54639E-146.75375E-141.05285E-149.11164E-151.19597E-1445.27560.3541990.335610.3725530.1954980.1823120.2082921008-32768
CXO J053514.3-05231783.80969326-5.388109810.16924TFF2.56431E-142.47535E-142.65417E-1417.40340.9851710.9785430.990966-0.00698975-0.0128563-0.002142129-327688-32768
CXO J053514.3-05225383.8098206-5.38164070.16466FTF2.05176E-141.98107E-142.12316E-1415.06490.5609340.5111230.6096980.2108210.1862940.2357788-327688-32768
CXO J053514.4-05232283.8099784-5.389665680.23553FFF4.66587E-154.28105E-155.05458E-1512.1756-0.0756736-0.135332-0.0170884-0.114952-0.183403-0.04508149-327688-32768
CXO J053514.3-05233383.80998065-5.392611560.14702FFF4.8023E-144.70178E-144.90384E-141.46049E-141.29563E-141.62703E-1427.6562-0.0825775-0.106809-0.0578608-0.124551-0.156265-0.092763908-32768
CXO J053514.5-05231583.81056936-5.387722330.17135TFF1.34289E-141.27463E-141.41184E-148.55561E-157.21816E-159.90657E-1512.0550.980620.9721170.987105-0.00429089-0.00957531-3.08654E-4297-32768
CXO J053514.5-05240783.81072267-5.402171190.2283TFF9.1153E-158.44146E-159.79595E-158.85950.9681810.951850.981924-0.00693137-0.01839430.002083141-327686-32768
CXO J053514.6-05232883.81100284-5.391226470.43437TFF3.78192E-153.14545E-154.42482E-155.92101-0.0631104-0.1776370.0523516-0.190031-0.324285-0.05577976-32768-32768-32768
CXO J053514.6-05230183.81109487-5.383790190.14849TTF7.39896E-147.29582E-147.50313E-149.53745E-158.13605E-151.0953E-1465.31240.1704920.1570440.1838820.1804090.169150.1915441008-32768
CXO J053514.6-05224983.81120139-5.380331760.18087FTF1.32936E-141.2721E-141.38719E-1413.95850.489440.4330170.5441770.2354060.2062460.26487-327687-32768
CXO J053514.7-05241283.81128448-5.403433550.19978TFF7.71247E-157.15899E-158.27154E-156.149470.3705670.2594660.47732-0.138487-0.2424-0.03476548-327685-32768
CXO J053514.7-05232283.81133486-5.389640170.14839TFF5.01776E-144.92056E-145.11593E-145.23879E-144.93591E-145.54472E-1429.55090.282670.2519080.3129920.2894080.2713140.3076821098-32768
CXO J053514.8-05240683.81170941-5.401853590.20687TFF1.95425E-141.8482E-142.06138E-1410.04250.9723710.959990.9833110.00443213-0.00117690.01082829-327688-32768
CXO J053514.8-05234683.8117676-5.396156710.15213TFF1.9664E-141.88916E-142.04442E-141.26507E-141.10556E-141.4262E-1412.2048-0.16864-0.213904-0.123749-0.213757-0.285474-0.140922805-32768
CXO J053514.8-05231583.81177012-5.387708690.17193TTF9.85838E-159.45421E-151.02666E-1415.2939-0.126347-0.166511-0.0858136-0.278406-0.332037-0.2237332-327686-32768
CXO J053514.8-05230483.81193361-5.384664250.17267TTF2.03975E-141.97508E-142.10508E-1420.24470.3173450.273840.3600550.2835140.2577430.3097278-327688-32768
CXO J053514.9-05241283.81217858-5.403510210.14801TFF5.3239E-145.22719E-145.4216E-141.58719E-141.41828E-141.75781E-1434.75230.04651750.02569840.0675352-0.107479-0.131671-0.08358841018-32768
CXO J053514.9-05232883.81220892-5.391332750.16083TTF4.68217E-154.2982E-155.07002E-153.58725E-152.70965E-154.46036E-157.89055-0.254059-0.369787-0.1397280.3698020.2576630.481755106-32768
CXO J053514.9-05233883.81228445-5.394169690.14232FFF1.49754E-131.48202E-131.51322E-132.82477E-132.75562E-132.89463E-1354.1441-0.0472355-0.0585613-0.0359605-0.150355-0.16636-0.1342271068-32768
CXO J053515.0-05235483.81265915-5.398419060.59443FFF3.93214E-152.99955E-154.86489E-154.16316-327682-32768-32768
CXO J053515.1-05230483.81297046-5.384515690.45384TFF1.88649E-159.06494E-162.8637E-153.053280.837230.7158030.933967-0.0320696-0.1187980.02930790-32768-32768-32768
CXO J053515.1-05234683.81314399-5.396215120.2003TFF4.39873E-153.92166E-154.88063E-154.00059E-153.0109E-154.9949E-155.6963-0.0285843-0.1028980.0406812-0.249534-0.381015-0.102094600-32768
CXO J053515.1-05225483.81329418-5.381724730.14462TFF1.64113E-131.62452E-131.65791E-131.6316E-141.43274E-141.83248E-1452.08920.4508760.4369260.4649470.1377640.1269990.1482641008-32768
CXO J053515.1-05231883.81330006-5.38854080.47766FTF3.49507E-152.3225E-154.65674E-153.821590.8547490.7530110.937876-0.0355204-0.1156130.02243680-32768-32768-32768
CXO J053515.2-05225683.81360368-5.382422180.1999TTF1.03202E-121.02837E-121.03571E-122.6702E-132.60158E-132.73951E-13130.5220.07047770.06444880.0764034-0.0717052-0.0779943-0.06552731008-32768
CXO J053515.3-05233383.81407441-5.392552720.14553TFF2.25803E-142.19797E-142.31869E-141.93736E-141.7427E-142.134E-1420.1199-0.137472-0.170874-0.103627-0.149193-0.192213-0.105697928-32768
CXO J053515.4-05234583.81434295-5.395906450.14712TFF5.51555E-145.41834E-145.61375E-149.9547E-158.51468E-151.14093E-1442.41070.08624150.07128330.10104-0.00267428-0.02186730.01664361008-32768
CXO J053515.4-05224883.8145085-5.380115040.14676TTF1.04415E-131.03206E-131.05635E-138.82286E-157.076E-151.05874E-1441.8304-0.0174547-0.03541588.28379E-4-0.0411823-0.0614385-0.02098211008-32768
CXO J053515.4-05233783.81455127-5.393761290.45111TFF1.41203E-159.77813E-161.84263E-154.3122-0.0434585-0.2293190.1404490.184190.002170750.3672311-32768-32768-32768
CXO J053515.5-05224683.81473478-5.379482930.31051TTF1.67177E-141.5583E-141.78639E-1412.19930.9376940.9103390.9633170.0114968-0.003999620.02686778-327687-32768
CXO J053515.6-05240283.81504651-5.400787930.15306FFF1.91504E-141.83643E-141.99445E-145.66629E-145.35161E-145.98415E-1417.7872-0.178473-0.224961-0.131402-0.295806-0.362798-0.227692597-32768
CXO J053515.6-05225683.81514589-5.38230260.1784FTF8.55289E-138.52034E-138.58577E-132.02006E-122.00158E-122.03873E-12129.7320.06120330.05515430.06729-0.0245866-0.0308778-0.01828081088-32768
CXO J053515.7-05233983.815411-5.39418110.39841TTF2.05992E-141.74398E-142.37906E-146.298740.6071130.5002760.7077730.1608630.1060580.2192750-32768-32768-32768
CXO J053515.7-05241183.81562914-5.4032036400000010.642673FFF3.80835E-162.06299E-165.56111E-163.93135-0.147377-0.27926-0.0136489-0.32344-0.508552-0.1290116-32768-32768-32768
CXO J053515.7-05233883.8157219-5.393905520.45063TTF3.18339E-142.77075E-143.60019E-147.274520.8226390.754310.886820.05256130.01510420.0905968-32768-32768-32768
CXO J053515.7-05230983.81574739-5.386068320.40301TTF3.03573E-123.029E-123.04254E-121.87491E-121.85709E-121.89291E-12202.7380.2745770.2708270.27825-0.0459597-0.0495455-0.0423645808-32768
CXO J053515.8-05230583.81588895-5.384850940.48598TFF9.31635E-158.2033E-151.04407E-149.11467-0.137899-0.205363-0.0699988-0.283179-0.370767-0.1910452-32768-32768-32768
CXO J053515.8-05231383.815963-5.387269780.40057TTF2.77082E-122.76452E-122.77719E-121.01992E-121.00666E-121.0333E-12197.5730.2593730.2554830.263164-0.04572-0.0494406-0.0419462908-32768
CXO J053515.8-05224583.81598875-5.379342370.15512TTF1.5406E-141.492E-141.5897E-143.40691E-152.32026E-154.49824E-1521.9792-0.0994224-0.130616-0.0679763-0.14147-0.181277-0.10211008-32768
CXO J053515.8-05232283.81610029-5.389536890.43705FFF1.97845E-141.67432E-142.28564E-145.331780.6443250.5233450.765435-0.140958-0.260161-0.02207170-32768-32768-32768
CXO J053515.8-05231883.81611207-5.388564860.44418TFF1.13066E-149.23675E-151.33974E-145.95239-0.0905449-0.1795065.26605E-4-0.431631-0.554358-0.3042640-32768-32768-32768
CXO J053515.8-05230183.81612461-5.383826110.23917FFF8.45856E-157.64832E-159.277E-157.90999-0.0861684-0.170009-0.00161331-0.158934-0.263449-0.04897870-327685-32768
CXO J053515.8-05223383.81613303-5.375850420.37078FFF1.7933E-151.4194E-152.16863E-155.23268-0.474765-0.592407-0.3543120.2604580.1023380.4173318-327685-32768
CXO J053515.8-05231083.81619-5.38630280.48816TTF4.64943E-134.5283E-134.77179E-1337.3210.2481120.2260140.270410.1358020.1177040.1536399-32768-32768-32768
CXO J053515.9-05241783.8162912-5.404918450.6885FFF3.78186E-152.91713E-154.65E-154.3122-327682-32768-32768
CXO J053515.9-05234983.81647584-5.397132680.14102TTF3.87473E-133.85092E-133.89878E-131.89669E-131.83958E-131.95437E-1373.52940.06420110.06295230.06545310.02228160.01116470.03332331078-32768
CXO J053516.0-05235283.81675305-5.398013650.14462TTF1.00513E-139.911E-141.0193E-131.48552E-141.31388E-141.65889E-1435.66260.1577340.1350770.1801050.04367720.02217740.06521251018-32768
CXO J053516.0-05225383.81698406-5.381644260.16235FFF3.26789E-143.18198E-143.35468E-1425.14920.8655710.8466840.8835930.06549860.0563930.07499129-327688-32768
CXO J053516.0-05230683.81701311-5.385221350.14238TTF1.76855E-131.75356E-131.7837E-135.32069E-144.98546E-145.65931E-1468.69430.06384250.05291150.0748212-0.0784673-0.0903596-0.06631971008-32768
CXO J053516.0-05232583.8170161-5.390400070.42036TTF1.00543E-149.06073E-151.10579E-1411.0945-0.125453-0.17706-0.0731745-0.344981-0.416858-0.2726620-32768-32768-32768
CXO J053516.0-05241183.8170323-5.40311780.18202FFF2.25929E-142.13907E-142.38072E-143.44264E-152.59187E-154.29976E-1512.9669-0.0641377-0.121644-0.00538426-0.016818-0.08418430.0495484728-32768
CXO J053516.0-05232283.81705333-5.38966350.1439TTF8.06604E-147.93614E-148.19725E-149.51118E-156.51756E-151.25222E-1435.91280.5750930.556270.594211-0.0963508-0.113819-0.0786152808-32768
CXO J053516.1-05231383.81720052-5.387088750.29045TFF1.17102E-141.06569E-141.27741E-146.713410.1791130.09075050.272076-0.316139-0.42591-0.2033087-327680-32768
CXO J053516.1-05230983.8172558-5.385986550.44726TTF3.83267E-152.89841E-154.77108E-153.4279-0.0114393-0.2001160.16813-0.0802978-0.3103410.1738810-32768-32768-32768
CXO J053516.1-05223783.81744498-5.377021050.16304FFF1.24777E-141.20505E-141.29091E-143.88118E-152.96665E-154.78877E-1515.55030.08887850.03592650.1414310.1099170.05870910.16105708-32768
CXO J053516.2-05231883.81746865-5.388547140.29102TTF1.7293E-141.62498E-141.83469E-1411.8731-0.0821205-0.134065-0.0290845-0.217927-0.288334-0.1446486-327684-32768
CXO J053516.2-05231683.8178479-5.387863850.15414TTF3.32569E-143.24069E-143.41155E-1416.95680.2141850.1715840.256628-0.0273673-0.07456240.02074589-327688-32768
CXO J053516.3-05240383.81822268-5.400864820.14238TFF5.65119E-135.60431E-135.69854E-131.1893E-131.14403E-131.23504E-1366.14610.1204210.1080760.1329240.05653060.04456260.0685104808-32768
CXO J053516.4-05232983.81859564-5.391421350.43656FFF1.33598E-141.16336E-141.51034E-148.24052-0.107666-0.166067-0.0482851-0.560076-0.642993-0.4750820-32768-32768-32768
CXO J053516.4-05233183.81861877-5.392001980.4145TTF4.70839E-153.72184E-155.70217E-153.954510.10125-0.04738530.247861-0.213178-0.403455-0.007613780-32768-32768-32768
CXO J053516.4-05232283.81863682-5.389643950.16555TTF3.15953E-123.15334E-123.16578E-121.93706E-111.93136E-111.94281E-11335.79-0.0574404-0.0603554-0.054598-0.179857-0.183533-0.176244708-32768
CXO J053516.4-05225683.81868061-5.382314380.25375FFF9.13394E-158.46442E-159.81021E-1510.10850.5325910.4602160.6035360.2199550.1839530.2568898-327688-32768
CXO J053516.4-05223483.81869862-5.376372810.16109TFF1.71057E-141.66378E-141.75782E-143.92169E-152.98105E-154.87032E-1523.0625-0.110707-0.140501-0.0809267-0.146559-0.184692-0.1075921008-32768
CXO J053516.5-05240583.81907688-5.401607150.14862TFF6.17377E-146.00346E-146.34581E-142.21828E-142.01516E-142.42345E-1420.473-0.0114133-0.04820040.0240581-0.0682099-0.110431-0.0262589908-32768
CXO J053516.6-05231583.81916799-5.387719410.2965TTF2.38905E-142.24716E-142.53237E-1411.23430.4593880.3942760.524993-0.0552914-0.124190.01786396-327686-32768
CXO J053516.7-05223183.81971948-5.375297560.15804TFF5.06851E-144.98874E-145.14908E-145.06829E-154.00493E-156.13022E-1544.56360.03107840.01498520.0471353-0.0098311-0.02873030.009040381018-32768
CXO J053516.7-05231683.81979918-5.387833230.15457TTF5.41387E-145.31441E-145.51433E-1442.00050.343890.3244760.3632420.1374740.1201540.15502610-327688-32768
CXO J053516.7-05232783.81985651-5.391061850.15396TTF3.1808E-143.10464E-143.25773E-1419.3821-0.173608-0.219488-0.1283080.3530160.309270.3970480-327687-32768
CXO J053516.7-05240483.81985811-5.401120960.14189TTF6.14592E-136.09573E-136.19661E-131.20933E-131.16357E-131.25557E-1362.35060.0766460.06429060.0891912-0.0215484-0.0345894-0.00835781018-32768
CXO J053516.9-05224883.82067804-5.380036020.26011TFF3.40385E-153.02903E-153.78245E-156.5724-0.209941-0.311983-0.1061490.208570.09926210.3155036-327680-32768
CXO J053516.9-05230083.82072056-5.383544430.1809FTF4.38438E-153.98639E-154.7864E-152.73814E-151.91129E-153.55782E-158.924460.0812748-0.02006440.1810620.3042170.245670.364153626-32768
CXO J053516.9-05233683.82074477-5.393578580.1656TFF6.65737E-156.25524E-157.06356E-159.300350.3790740.286050.4702260.1182460.02878470.2053747-327686-32768
CXO J053517.0-05223283.82085444-5.375792420.14172TTF5.12055E-135.09571E-135.14564E-131.51166E-131.46086E-131.56297E-13104.4610.04190940.03474950.0490269-0.0550702-0.0631752-0.04713081008-32768
CXO J053517.0-05233983.82106838-5.394322940.14281TFF6.18657E-146.09481E-146.27926E-141.1665E-131.1214E-131.21206E-1332.3985-0.0297006-0.0531671-0.00677787-0.0486834-0.0749776-0.022494510106-32768
CXO J053517.0-05233383.82109826-5.392738150.1631TTF1.02987E-121.02531E-121.03447E-128.75803E-148.36184E-149.15822E-14127.4990.6308090.6252370.6363340.1649650.1618630.1680621008-32768
CXO J053517.1-05224983.82131869-5.380532610.19466TFF4.86951E-154.52284E-155.21969E-153.98751E-153.07147E-154.89601E-1512.7202-0.143314-0.192783-0.0933213-0.259469-0.324615-0.193064717-32768
CXO J053517.2-05231683.82189417-5.387890010.14245FTF5.88682E-145.81311E-145.96127E-148.88455E-148.48444E-149.2887E-1438.8741-0.106269-0.113609-0.0990529-0.77797-0.792073-0.76355000-32768
CXO J053517.2-05242383.82196154-5.406661650.21976FFF2.62389E-152.3843E-152.8659E-157.6888-0.19058-0.261001-0.121977-0.414758-0.517638-0.3089097-327685-32768
CXO J053517.3-05223583.82228078-5.376539420.20984TFF5.84579E-155.32199E-156.37489E-157.458950.6994690.6074030.7895280.1142610.06564620.1627438-327685-32768
CXO J053517.3-05224583.82234198-5.379312170.22014TFF6.80224E-156.2389E-157.37126E-156.67030.3966090.2827380.507870.2689180.2099310.3290878-327685-32768
CXO J053517.3-05230483.82237467-5.384617450.42463FFF9.77684E-158.70144E-151.08631E-149.49126-0.0447789-0.1439270.05211080.3941110.3114050.476199-32768-32768-32768
CXO J053517.3-05240083.8224061-5.400022110.18139FFF1.85293E-141.74155E-141.96543E-143.45141E-152.58232E-154.31257E-159.242790.7554740.6954030.8103550.09393390.06617190.1257815-32768
CXO J053517.3-05241383.82244801-5.403813310.19226TFF4.69414E-154.36344E-155.02817E-152.84905E-152.06367E-153.63713E-157.67701-0.186065-0.262651-0.104858-0.0730942-0.1731020.029691210-32768
CXO J053517.4-05232083.82275909-5.389137780.14305TFF6.19418E-146.10112E-146.28819E-149.46104E-149.05153E-149.87468E-1433.9473-0.120336-0.139946-0.100275-0.173029-0.198721-0.147012828-32768
CXO J053517.4-05225183.82278772-5.380856180.26154FFF1.59443E-141.48174E-141.70825E-1410.32170.9678240.9484240.983472-0.0020122-0.01290.0077893210-327680-32768
CXO J053517.4-05241783.8228207-5.404766430.17747TFF6.73012E-156.40928E-157.0542E-1512.4071-0.134308-0.178341-0.0910805-0.39546-0.458828-0.3325257-327686-32768
CXO J053517.5-05225683.82316819-5.382397640.15331FTF2.83102E-142.76496E-142.89775E-147.30177E-156.08289E-158.53297E-1522.53820.2105740.1749350.2454330.0311087-0.002876640.06574811018-32768
CXO J053517.7-05223083.82394082-5.375175470.492273FFF2.57352E-152.04402E-153.10329E-154.979050.4351060.2905640.5734090.1667670.06405620.2651732-32768-32768-32768
CXO J053517.7-05234283.82403421-5.395072420.2641TTF2.22294E-142.09875E-142.34839E-1414.64980.3939850.3360880.4508330.2368580.2057780.2685048-327688-32768
CXO J053517.7-05234483.82408397-5.395568380.15493TTF4.40876E-144.30497E-144.5136E-146.16894E-155.06292E-157.28614E-1524.0684-0.0935179-0.125494-0.06166430.012234-0.02494150.0495115918-32768
CXO J053517.8-05231583.82422327-5.387610970.14969TTF2.14931E-142.09499E-142.20418E-145.5013E-154.37611E-156.62636E-1521.7772-0.0485423-0.0781495-0.0186874-0.238534-0.27681-0.200386908-32768
CXO J053517.8-05230283.82443905-5.384140230.15408FFF2.47255E-142.41076E-142.53496E-143.99183E-153.06073E-154.9291E-1519.7450.0294182-0.01209830.07060360.1527620.1115780.19379806-32768
CXO J053517.9-05224583.82479363-5.379299550.40131TTF2.34246E-122.33673E-122.34825E-127.72945E-137.61515E-137.8449E-13192.1130.1766570.1726920.180645-0.017412-0.021351-0.01341551008-32768
CXO J053517.9-05233583.82483373-5.393116990.159TFF5.0092E-154.57792E-155.44484E-156.66509E-155.48228E-157.85984E-157.34797-0.194774-0.261407-0.128891-0.309379-0.418885-0.197315000-32768
CXO J053517.9-05224083.82493994-5.377993850.46551TTF4.98307E-154.215E-155.75889E-156.088870.0498089-0.04374020.140453-0.46677-0.579925-0.3510989-32768-32768-32768
CXO J053518.0-05240283.82516072-5.400818540.15291TTF4.64651E-144.5185E-144.77582E-147.56507E-156.29819E-158.84474E-1517.8490.3365570.2868510.3853790.2526720.2247120.280702908-32768
CXO J053518.0-05240083.82528688-5.400271070.14991TTF4.04349E-143.94916E-144.13877E-141.52375E-141.35145E-141.6978E-1429.5094-0.0313176-0.0572702-0.00540553-0.028688-0.0578774.73572E-4908-32768
CXO J053518.2-05233583.82583666-5.393249910.14673TFF6.27032E-146.15475E-146.38706E-141.45277E-141.28904E-141.61815E-1440.86340.3390680.3194490.3584840.06820790.05232780.08397311008-32768
CXO J053518.2-05231583.82596286-5.387602670.34924FFF2.1647E-151.51151E-152.81364E-153.55219-0.0952553-0.2195410.0294111-0.273004-0.45569-0.0662922-327685-32768
CXO J053518.3-05224183.82636223-5.378149580.52516TFF4.78337E-154.06288E-155.51113E-156.91727-0.01251-0.09984480.0765684-0.32761-0.437286-0.2132640-32768-32768-32768
CXO J053518.3-05240483.82637823-5.401300880.15454TFF1.50312E-141.4616E-141.54506E-149.74068E-158.39717E-151.10978E-1418.2882-0.0170644-0.04512440.0113308-0.496462-0.534808-0.4579241026-32768
CXO J053518.3-05223783.82655004-5.377070750.4015TTF1.51757E-121.51311E-121.52209E-124.8168E-134.72606E-134.90845E-13156.0290.08171650.07667810.0867794-0.0223465-0.02765-0.01711891098-32768
CXO J053518.4-05240683.82694247-5.401912650.16124TTF1.37515E-141.33676E-141.41392E-142.62695E-151.92102E-153.45326E-1520.2619-0.147293-0.177667-0.116693-0.254688-0.297129-0.212164928-32768
CXO J053518.5-05232983.82710603-5.391395440.29924FFF3.55482E-153.07533E-154.03916E-155.196010.0224992-0.08852410.1335070.0140313-0.1004490.132519-327680-32768
CXO J053518.6-05231383.82775602-5.38714750.1553FFF5.06073E-144.95229E-145.17026E-142.48157E-151.74615E-153.21853E-1520.30470.7112470.6809130.7405750.09778370.08229360.113861818-32768
CXO J053518.7-05225683.82792335-5.382410030.14563FTF8.38129E-148.2714E-148.49229E-142.00977E-141.81923E-142.20222E-1440.73870.05723740.036320.07792740.1563190.1364810.1758571068-32768
CXO J053518.8-05230683.8285511-5.385206880.38307TFF3.13434E-152.6248E-153.64903E-154.100980.5170240.3874920.6478820.1362210.04525470.2230877-327683-32768
CXO J053518.8-05232883.82863504-5.391309350.18426TFF7.80936E-157.34268E-158.28074E-153.41606E-152.54272E-154.2936E-1513.50890.1483360.08621140.2091090.1169380.06065270.17337807-32768
CXO J053518.8-05241783.82870493-5.404799450.2054FFF2.02885E-151.8429E-152.21669E-152.54071E-151.81143E-153.27084E-157.47107-0.111318-0.206769-0.0157024-0.105823-0.2175570.0062841715-32768
CXO J053518.9-05232183.82900851-5.389388790.18377FFF6.29657E-155.91494E-156.68206E-153.93679E-153.03809E-154.84281E-159.75966-0.197391-0.257914-0.136809-0.0810207-0.1735160.0124436827-32768
CXO J053519.0-05234983.82943179-5.397077450.18362TFF1.26527E-141.19883E-141.33238E-142.50362E-151.77341E-153.23775E-159.537040.5254230.461240.5880780.05526250.01680230.0953571305-32768
CXO J053519.0-05230783.82947555-5.385385530.60007TFF3.06568E-152.35388E-153.77334E-153.372580.5517880.3641720.7309360.0525947-0.07883570.1807341-32768-32768-32768
CXO J053519.1-05232683.82965729-5.390792190.149TFF4.70476E-144.6041E-144.80644E-143.13813E-142.90203E-143.37661E-1429.1204-0.0186874-0.04554050.008320420.0217701-0.007979790.05139391008-32768
CXO J053519.2-05225083.83003508-5.380692480.14563FTF7.71165E-147.6122E-147.8121E-142.18413E-141.98589E-142.38437E-1435.18450.0103539-0.01239920.0334530.06222180.038350.0862733808-32768
CXO J053519.3-05230683.83073658-5.385086420.20406TFF3.86105E-153.52179E-154.20375E-151.51947E-141.35327E-141.68735E-149.031090.708850.647330.7628360.1186350.08998350.149562825-32768
CXO J053519.6-05235783.83170407-5.39920850.14599FFF5.65477E-145.57404E-145.73631E-141.58911E-141.41853E-141.76143E-1433.2056-0.0563964-0.0777684-0.0345916-0.0881097-0.114265-0.06163211008-32768
CXO J053519.6-05230383.83180325-5.384295030.28673TFF3.38795E-143.25298E-143.52428E-1424.19230.5219230.4900190.5529170.1681570.1480410.18761710-327688-32768
CXO J053520.1-05230883.83405767-5.385651340.17176FFF1.6732E-141.60671E-141.74036E-148.91914E-157.62577E-151.02256E-1416.73780.7048720.6676550.740770.08029040.05641530.103995988-32768
CXO J053520.4-05232983.83524928-5.391579150.14495FTF1.48294E-131.46302E-131.50305E-136.19981E-145.87156E-146.53138E-1437.6376-0.0342289-0.0543452-0.0144118-0.0400774-0.0630867-0.01710711008-32768
CXO J053520.6-05235383.83613982-5.398070620.14505FFF1.22974E-131.21659E-131.24301E-133.53667E-143.28387E-143.79203E-1451.6767-0.0736723-0.0873284-0.0601008-0.114096-0.131036-0.09706451088-32768
CXO J053520.9-05232183.83713079-5.389376130.17294FFF1.27352E-141.22038E-141.32719E-144.79489E-153.76627E-155.82531E-1515.092-0.00451392-0.05067690.0414142-0.143189-0.198027-0.0872535917-32768
CXO J053521.0-05234883.83769663-5.396902990.16319FTF9.62079E-139.58324E-139.65871E-134.11609E-134.032E-134.20101E-13120.3810.02733040.02113110.0335637-0.0775369-0.0845064-0.0706931058-32768
+ + diff --git a/pkg/utilities/nttools/zz_rewrite.xml b/pkg/utilities/nttools/zz_rewrite.xml new file mode 100644 index 00000000..d3e2b883 --- /dev/null +++ b/pkg/utilities/nttools/zz_rewrite.xml @@ -0,0 +1,1191 @@ + + + + + + +Chandra Source Catalog VO Cone Search Service + + + + + + + + +Source name in the format 'CXO Jhhmmss.s +/- ddmmss' + + +Source position, ICRS right ascension + + +Source position, ICRS declination + + +Aperture-corrected net energy flux inferred from the source region aperture, calculated by counting X-ray events; HRC wide energy band + + +Aperture-corrected net energy flux inferred from the source region aperture, calculated by counting X-ray events (68% lower confidence limit); HRC wide energy band + + +Inter-observation variability index in the range [0, 10]; indicates whether the source region photon flux is constant between observations; ACIS broad energy band + + +Inter-observation variability index in the range [0, 10]; indicates whether the source region photon flux is constant between observations; HRC wide energy band + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
CXO J053513.4-05234083.80601567-5.394484315.88765E-145.56953E-148-32768
CXO J053513.5-05233083.80637907-5.391853043.03441E-142.80268E-148-32768
CXO J053513.9-05231983.80801443-5.38886036-32768
CXO J053514.0-05233883.8085595-5.39395772.97063E-142.74026E-148-32768
CXO J053514.2-05230483.80953052-5.384448898-32768
CXO J053514.3-05230883.80962741-5.385577121.05285E-149.11164E-158-32768
CXO J053514.3-05231783.80969326-5.388109818-32768
CXO J053514.3-05225383.8098206-5.38164078-32768
CXO J053514.4-05232283.8099784-5.389665688-32768
CXO J053514.3-05233383.80998065-5.392611561.46049E-141.29563E-148-32768
CXO J053514.5-05231583.81056936-5.387722338.55561E-157.21816E-157-32768
CXO J053514.5-05240783.81072267-5.402171196-32768
CXO J053514.6-05232883.81100284-5.39122647-32768-32768
CXO J053514.6-05230183.81109487-5.383790199.53745E-158.13605E-158-32768
CXO J053514.6-05224983.81120139-5.380331767-32768
CXO J053514.7-05241283.81128448-5.403433555-32768
CXO J053514.7-05232283.81133486-5.389640175.23879E-144.93591E-148-32768
CXO J053514.8-05240683.81170941-5.401853598-32768
CXO J053514.8-05234683.8117676-5.396156711.26507E-141.10556E-145-32768
CXO J053514.8-05231583.81177012-5.387708696-32768
CXO J053514.8-05230483.81193361-5.384664258-32768
CXO J053514.9-05241283.81217858-5.403510211.58719E-141.41828E-148-32768
CXO J053514.9-05232883.81220892-5.391332753.58725E-152.70965E-156-32768
CXO J053514.9-05233883.81228445-5.394169692.82477E-132.75562E-138-32768
CXO J053515.0-05235483.81265915-5.398419063.93214E-152.99955E-15-32768-32768
CXO J053515.1-05230483.81297046-5.38451569-32768-32768
CXO J053515.1-05234683.81314399-5.396215124.00059E-153.0109E-150-32768
CXO J053515.1-05225483.81329418-5.381724731.6316E-141.43274E-148-32768
CXO J053515.1-05231883.81330006-5.3885408-32768-32768
CXO J053515.2-05225683.81360368-5.382422182.6702E-132.60158E-138-32768
CXO J053515.3-05233383.81407441-5.392552721.93736E-141.7427E-148-32768
CXO J053515.4-05234583.81434295-5.395906459.9547E-158.51468E-158-32768
CXO J053515.4-05224883.8145085-5.380115048.82286E-157.076E-158-32768
CXO J053515.4-05233783.81455127-5.39376129-32768-32768
CXO J053515.5-05224683.81473478-5.379482937-32768
CXO J053515.6-05240283.81504651-5.400787935.66629E-145.35161E-147-32768
CXO J053515.6-05225683.81514589-5.38230262.02006E-122.00158E-128-32768
CXO J053515.7-05233983.815411-5.3941811-32768-32768
CXO J053515.7-05241183.81562914-5.403203640000001-32768-32768
CXO J053515.7-05233883.8157219-5.39390552-32768-32768
CXO J053515.7-05230983.81574739-5.386068321.87491E-121.85709E-128-32768
CXO J053515.8-05230583.81588895-5.38485094-32768-32768
CXO J053515.8-05231383.815963-5.387269781.01992E-121.00666E-128-32768
CXO J053515.8-05224583.81598875-5.379342373.40691E-152.32026E-158-32768
CXO J053515.8-05232283.81610029-5.38953689-32768-32768
CXO J053515.8-05231883.81611207-5.38856486-32768-32768
CXO J053515.8-05230183.81612461-5.383826115-32768
CXO J053515.8-05223383.81613303-5.375850425-32768
CXO J053515.8-05231083.81619-5.3863028-32768-32768
CXO J053515.9-05241783.8162912-5.404918453.78186E-152.91713E-15-32768-32768
CXO J053515.9-05234983.81647584-5.397132681.89669E-131.83958E-138-32768
CXO J053516.0-05235283.81675305-5.398013651.48552E-141.31388E-148-32768
CXO J053516.0-05225383.81698406-5.381644268-32768
CXO J053516.0-05230683.81701311-5.385221355.32069E-144.98546E-148-32768
CXO J053516.0-05232583.8170161-5.39040007-32768-32768
CXO J053516.0-05241183.8170323-5.40311783.44264E-152.59187E-158-32768
CXO J053516.0-05232283.81705333-5.38966359.51118E-156.51756E-158-32768
CXO J053516.1-05231383.81720052-5.387088750-32768
CXO J053516.1-05230983.8172558-5.38598655-32768-32768
CXO J053516.1-05223783.81744498-5.377021053.88118E-152.96665E-158-32768
CXO J053516.2-05231883.81746865-5.388547144-32768
CXO J053516.2-05231683.8178479-5.387863858-32768
CXO J053516.3-05240383.81822268-5.400864821.1893E-131.14403E-138-32768
CXO J053516.4-05232983.81859564-5.39142135-32768-32768
CXO J053516.4-05233183.81861877-5.39200198-32768-32768
CXO J053516.4-05232283.81863682-5.389643951.93706E-111.93136E-118-32768
CXO J053516.4-05225683.81868061-5.382314388-32768
CXO J053516.4-05223483.81869862-5.376372813.92169E-152.98105E-158-32768
CXO J053516.5-05240583.81907688-5.401607152.21828E-142.01516E-148-32768
CXO J053516.6-05231583.81916799-5.387719416-32768
CXO J053516.7-05223183.81971948-5.375297565.06829E-154.00493E-158-32768
CXO J053516.7-05231683.81979918-5.387833238-32768
CXO J053516.7-05232783.81985651-5.391061857-32768
CXO J053516.7-05240483.81985811-5.401120961.20933E-131.16357E-138-32768
CXO J053516.9-05224883.82067804-5.380036020-32768
CXO J053516.9-05230083.82072056-5.383544432.73814E-151.91129E-156-32768
CXO J053516.9-05233683.82074477-5.393578586-32768
CXO J053517.0-05223283.82085444-5.375792421.51166E-131.46086E-138-32768
CXO J053517.0-05233983.82106838-5.394322941.1665E-131.1214E-136-32768
CXO J053517.0-05233383.82109826-5.392738158.75803E-148.36184E-148-32768
CXO J053517.1-05224983.82131869-5.380532613.98751E-153.07147E-157-32768
CXO J053517.2-05231683.82189417-5.387890018.88455E-148.48444E-140-32768
CXO J053517.2-05242383.82196154-5.406661655-32768
CXO J053517.3-05223583.82228078-5.376539425-32768
CXO J053517.3-05224583.82234198-5.379312175-32768
CXO J053517.3-05230483.82237467-5.38461745-32768-32768
CXO J053517.3-05240083.8224061-5.400022113.45141E-152.58232E-155-32768
CXO J053517.3-05241383.82244801-5.403813312.84905E-152.06367E-150-32768
CXO J053517.4-05232083.82275909-5.389137789.46104E-149.05153E-148-32768
CXO J053517.4-05225183.82278772-5.380856180-32768
CXO J053517.4-05241783.8228207-5.404766436-32768
CXO J053517.5-05225683.82316819-5.382397647.30177E-156.08289E-158-32768
CXO J053517.7-05223083.82394082-5.37517547-32768-32768
CXO J053517.7-05234283.82403421-5.395072428-32768
CXO J053517.7-05234483.82408397-5.395568386.16894E-155.06292E-158-32768
CXO J053517.8-05231583.82422327-5.387610975.5013E-154.37611E-158-32768
CXO J053517.8-05230283.82443905-5.384140233.99183E-153.06073E-156-32768
CXO J053517.9-05224583.82479363-5.379299557.72945E-137.61515E-138-32768
CXO J053517.9-05233583.82483373-5.393116996.66509E-155.48228E-150-32768
CXO J053517.9-05224083.82493994-5.37799385-32768-32768
CXO J053518.0-05240283.82516072-5.400818547.56507E-156.29819E-158-32768
CXO J053518.0-05240083.82528688-5.400271071.52375E-141.35145E-148-32768
CXO J053518.2-05233583.82583666-5.393249911.45277E-141.28904E-148-32768
CXO J053518.2-05231583.82596286-5.387602675-32768
CXO J053518.3-05224183.82636223-5.37814958-32768-32768
CXO J053518.3-05240483.82637823-5.401300889.74068E-158.39717E-156-32768
CXO J053518.3-05223783.82655004-5.377070754.8168E-134.72606E-138-32768
CXO J053518.4-05240683.82694247-5.401912652.62695E-151.92102E-158-32768
CXO J053518.5-05232983.82710603-5.391395440-32768
CXO J053518.6-05231383.82775602-5.38714752.48157E-151.74615E-158-32768
CXO J053518.7-05225683.82792335-5.382410032.00977E-141.81923E-148-32768
CXO J053518.8-05230683.8285511-5.385206883-32768
CXO J053518.8-05232883.82863504-5.391309353.41606E-152.54272E-157-32768
CXO J053518.8-05241783.82870493-5.404799452.54071E-151.81143E-155-32768
CXO J053518.9-05232183.82900851-5.389388793.93679E-153.03809E-157-32768
CXO J053519.0-05234983.82943179-5.397077452.50362E-151.77341E-155-32768
CXO J053519.0-05230783.82947555-5.38538553-32768-32768
CXO J053519.1-05232683.82965729-5.390792193.13813E-142.90203E-148-32768
CXO J053519.2-05225083.83003508-5.380692482.18413E-141.98589E-148-32768
CXO J053519.3-05230683.83073658-5.385086421.51947E-141.35327E-145-32768
CXO J053519.6-05235783.83170407-5.39920851.58911E-141.41853E-148-32768
CXO J053519.6-05230383.83180325-5.384295038-32768
CXO J053520.1-05230883.83405767-5.385651348.91914E-157.62577E-158-32768
CXO J053520.4-05232983.83524928-5.391579156.19981E-145.87156E-148-32768
CXO J053520.6-05235383.83613982-5.398070623.53667E-143.28387E-148-32768
CXO J053520.9-05232183.83713079-5.389376134.79489E-153.76627E-157-32768
CXO J053521.0-05234883.83769663-5.396902994.11609E-134.032E-138-32768
+ + diff --git a/pkg/utilities/pffctn.x b/pkg/utilities/pffctn.x new file mode 100644 index 00000000..277ad384 --- /dev/null +++ b/pkg/utilities/pffctn.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +# PF_FCTN -- function required by REGRES to define polynomial function +# This routine taken from Bevington, Page 177. + +real procedure pf_fctn (x, i, j, jterms) + +real x[ARB] +int i, j +int jterms[ARB] +int jexp + +begin + jexp = jterms[j] + return (x[i] ** jexp) +end diff --git a/pkg/utilities/pfregres.f b/pkg/utilities/pfregres.f new file mode 100644 index 00000000..2edb1884 --- /dev/null +++ b/pkg/utilities/pfregres.f @@ -0,0 +1,183 @@ +c subroutine regres.f +c +c source +c Bevington, pages 172-175. +c +c purpose +c make a mulitple linear regression fit to data with a specified +c function which is linear in coefficients +c +c usage +c call regres (x, y, sigmay, npts, nterms, m, mode, yfit, +c a0, a, sigma0, sigmaa, r, rmul, chisqr, ftest) +c +c description of parameters +c x - array of points for independent variable +c y - array of points for dependent variable +c sigmay - array of standard deviations for y data points +c npts - number of pairs of data points +c nterms - number of coefficients +c m - array of inclusion/rejection criteria for fctn +c mode - determines method of weighting least-squares fit +c +1 (instrumental) weight(i) = 1./sigmay(i)**2 +c 0 (no weighting) weight(i) = 1. +c -1 (statistical) weight(i) = 1./y(i) +c yfit - array of calculated values of y +c a0 - constant term +c a - array of coefficients +c sigma0 - standard deviation of a0 +c sigmaa - array of standard deviations for coefficients +c r - array of linear correlation coefficients +c rmul - multiple linear correlation coefficient +c chisqr - reduced chi square for fit +c ftest - value of f for test of fit +c +c subroutines and function subprograms required +c fctn (x, i, j, m) +c evaluates the function for the jth term and the ith data point +c using the array m to specify terms in the function +c matinv (array, nterms, det) +c inverts a symmetric two-dimensional matrix of degree nterms +c and calculates its determinant +c +c comments +c (dim npts changed 100->1000 21-may-84 dct) +c dimension statement valid for npts up to 100 and nterms up to 10 +c sigmaag changed to sigmaa in statement following statement 132 +c + subroutine pfregs (x,y,sigmay,npts,nterms,m,mode,yfit, + *a0,a,sigma0,sigmaa,r,rmul,chisqr,ftest,fctn) + double precision array,sum,ymean,sigma,chisq,xmean,sigmax + dimension x(1),y(1),sigmay(1),m(1),yfit(1),a(1),sigmaa(1), + *r(1) + dimension weight(1000),xmean(10),sigmax(10),array(10,10) + external fctn +c +c initialize sums and arrays +c +11 sum=0. + ymean=0. + sigma=0. + chisq=0. + rmul=0. + do 17 i=1,npts +17 yfit(i)=0. +21 do 28 j=1,nterms + xmean(j)=0. + sigmax(j)=0. + r(j)=0. + a(j)=0. + sigmaa(j)=0. + do 28 k=1,nterms +28 array(j,k)=0. +c +c accumulate weighted sums +c +30 do 50 i=1,npts +31 if (mode) 32,37,39 +32 if (y(i)) 35,37,33 +33 weight(i)=1./y(i) + goto 41 +35 weight(i)=1./(-y(i)) + goto 41 +37 weight(i)=1. + goto 41 +39 weight(i)=1./sigmay(i)**2 +41 sum=sum+weight(i) + ymean=ymean+weight(i)*y(i) + do 44 j=1,nterms +44 xmean(j)=xmean(j)+weight(i)*fctn(x,i,j,m) +50 continue +51 ymean=ymean/sum + do 53 j=1,nterms +53 xmean(j)=xmean(j)/sum + fnpts=npts + wmean=sum/fnpts + do 57 i=1,npts +57 weight(i)=weight(i)/wmean + +c +c accumulate matrices r and array +c +61 do 67 i=1,npts + sigma=sigma+weight(i)*(y(i)-ymean)**2 + do 67 j=1,nterms + sigmax(j)=sigmax(j)+weight(i)*(fctn(x,i,j,m)-xmean(j))**2 + r(j)=r(j)+weight(i)*(fctn(x,i,j,m)-xmean(j))*(y(i)-ymean) + do 67 k=1,j +67 array(j,k)=array(j,k)+weight(i)*(fctn(x,i,j,m)-xmean(j))* + *(fctn(x,i,k,m)-xmean(k)) +71 free1=npts-1 +72 sigma=dsqrt(sigma/free1) + do 78 j=1,nterms +74 sigmax(j)=dsqrt(sigmax(j)/free1) + r(j)=r(j)/(free1*sigmax(j)*sigma) + do 78 k=1,j + array(j,k)=array(j,k)/(free1*sigmax(j)*sigmax(k)) +78 array(k,j)=array(j,k) +c +c invert symmetric matrix +c +81 call matinv (array,nterms,det) + if (det) 101,91,101 +91 a0=0. + sigma0=0. + rmul=0. + chisqr=0. + ftest=0. + goto 150 +c +c calculate coefficients, fit, and chi square +c +101 a0=ymean +102 do 108 j=1,nterms + do 104 k=1,nterms +104 a(j)=a(j)+r(k)*array(j,k) +105 a(j)=a(j)*sigma/sigmax(j) +106 a0=a0-a(j)*xmean(j) +107 do 108 i=1,npts +108 yfit(i)=yfit(i)+a(j)*fctn(x,i,j,m) +111 do 113 i=1,npts + yfit(i)=yfit(i)+a0 +113 chisq=chisq+weight(i)*(y(i)-yfit(i))**2 + freen=npts-nterms-1 +115 chisqr=chisq*wmean/freen +c +c calculate uncertainties +c +121 if (mode) 122,124,122 +122 varnce=1./wmean + goto 131 +124 varnce=chisqr +131 do 133 j=1,nterms +132 sigmaa(j)=array(j,j)*varnce/(free1*sigmax(j)**2) + if (sigmaa(j)) 835, 835, 836 +835 sigmaa(j) = 0.0 + goto 133 +836 sigmaa(j)=sqrt(sigmaa(j)) +133 rmul=rmul+a(j)*r(j)*sigmax(j)/sigma + freej=nterms +c +noao: When rmul = 1, the following division (stmt 135) would blow up. +c It has been changed so ftest is set to -99999. in this case. + if (rmul) 935, 136, 136 +935 ftest = -99999. + rmul = -99999. + goto 141 +c -noao +136 if (1.0 - abs(rmul)) 1035, 1036, 1037 +1035 rmul=-99999. + ftest = -99999. + goto 141 +1036 ftest = -99999. + rmul = 1.0 + goto 141 +1037 ftest=(rmul/freej)/((1.-rmul)/freen) + rmul=sqrt(rmul) +141 sigma0=varnce/fnpts + do 145 j=1,nterms + do 145 k=1,nterms +145 sigma0=sigma0+varnce*xmean(j)*xmean(k)*array(j,k)/ + *(free1*sigmax(j)*sigmax(k)) +146 sigma0=sqrt(sigma0) +150 return + end diff --git a/pkg/utilities/polyfit.par b/pkg/utilities/polyfit.par new file mode 100644 index 00000000..88d68ae1 --- /dev/null +++ b/pkg/utilities/polyfit.par @@ -0,0 +1,5 @@ +input,f,a,STDIN,,,input files +order,i,a,,1,20,order of polynomial +weighting,s,h,"uniform",,,"Type of weighting (instrumental|uniform|statistical)" +verbose,b,h,no,,,list calculated fit to data +listdata,b,h,no,,,list X-Y pairs only diff --git a/pkg/utilities/split.par b/pkg/utilities/split.par new file mode 100644 index 00000000..926af8fb --- /dev/null +++ b/pkg/utilities/split.par @@ -0,0 +1,6 @@ +input,f,a,,,,input file +output,s,a,seg,,,root name for output (segment) files +nlines,i,h,1000,1,,maximum number of lines of text per segment file +nbytes,i,h,16384,1,,maximum number of bytes per segment file +maxfiles,i,h,999,,,maximum number of output files +verbose,b,h,yes,,,print output file names and sizes as they are generated diff --git a/pkg/utilities/surfit.par b/pkg/utilities/surfit.par new file mode 100644 index 00000000..37b0d5a2 --- /dev/null +++ b/pkg/utilities/surfit.par @@ -0,0 +1,18 @@ +input,f,a,,,,Input text file containing data to be fit +image,f,h,,,,Output surface image (optional) +coordinates,f,h,"",,,Text file of coordinates to be evaluated (optional) +fit,f,h,"",,,"Text file for output evaluated fit +" +function,s,h,"polynomial","chebyshev|legendre|polynomial",,Surface function +xorder,i,h,2,1,,X order of surface +yorder,i,h,2,1,,Y order of surface +xterms,s,h,"full","|none|full|half|",,Cross-terms type +weighting,s,h,"user","uniform|user|statistical|instrumental",,Weighting type +xmin,r,h,INDEF,,,Minimum X value over which surface is defined +xmax,r,h,INDEF,,,Maximum X value over which surface is defined +ymin,r,h,INDEF,,,Minimum Y value over which surface is defined +ymax,r,h,INDEF,,,Maximum Y value over which surface is defined +zmin,r,h,INDEF,,,Minimum Z value to include in fit +zmax,r,h,INDEF,,,Maximum Z value to include in fit +ncols,i,h,100,1,,Number of columns in output image +nlines,i,h,100,1,,Number of lines in output image diff --git a/pkg/utilities/t_curfit.x b/pkg/utilities/t_curfit.x new file mode 100644 index 00000000..af4dea06 --- /dev/null +++ b/pkg/utilities/t_curfit.x @@ -0,0 +1,446 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + +define VERBOSE_OUTPUT 1 +define LIST_OUTPUT 2 +define DEFAULT_OUTPUT 3 +define IMAGE_OP 1 +define LIST_OP 2 + +define CF_UNIFORM 1 +define CF_USER 2 +define CF_STATISTICAL 3 +define CF_INSTRUMENTAL 4 + +define NADD 20 # Number of points that can be added by ICFIT + +# T_CURFIT -- cl interface to the curfit package. Task CURFIT provides +# four fitting options: legendre, chebyshev, cubic spline or linear spline. +# The output can be printed in default, verbose or tabular formats. The +# user can also choose to interactively fit the curve. + +procedure t_curfit () + +pointer x, y, w, gt, fcn, fname, flist, dev, str, sp, ic +bool listdata, verbose, power, redir +int fd, ofmt, interactive, datatype +int axis, nvalues, nmax, weighting +pointer gt_init() +bool clgetb() +int imtopen(), clgeti(), cf_operand(), cf_rimage(), cf_rlist() +int imtgetim(), clgwrd() +int fstati() + +begin + # Allocate space for string buffers + call smark (sp) + call salloc (fcn, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (flist, SZ_LINE, TY_CHAR) + call salloc (dev, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # First get cl parameters. Check to see if input has been redirected. + redir = false + if (fstati (STDIN, F_REDIR) == YES) { + redir = true + call strcpy ("STDIN", Memc[fname], SZ_FNAME) + } else { + call clgstr ("input", Memc[flist], SZ_LINE) + fd = imtopen (Memc[flist]) + } + + listdata = clgetb ("listdata") + verbose = clgetb ("verbose") + ofmt = DEFAULT_OUTPUT + if (listdata) + ofmt = LIST_OUTPUT + else if (verbose) + ofmt = VERBOSE_OUTPUT + + # Determine the calculation datatype. + switch (clgwrd ("calctype", Memc[dev], SZ_FNAME, "|real|double|")) { + case 1: + datatype = TY_REAL + case 2: + datatype = TY_DOUBLE + } + + if (clgetb ("interactive")) { + interactive = YES + call clgstr ("device", Memc[dev], SZ_FNAME) + } else { + interactive = ALWAYSNO + call strcpy ("", Memc[dev], SZ_FNAME) + } + + power = clgetb ("power") + + call ic_open (ic) + call clgstr ("function", Memc[fcn], SZ_FNAME) + call ic_pstr (ic, "function", Memc[fcn]) + call ic_puti (ic, "order", clgeti ("order")) + weighting = clgwrd ("weighting", Memc[str], SZ_FNAME, + "|uniform|user|statistical|instrumental|") + + gt = gt_init () + + repeat { + if (!redir) { + if (imtgetim (fd, Memc[fname], SZ_FNAME) == EOF) + break + } + + if (cf_operand (Memc[fname]) == IMAGE_OP) { + axis = clgeti ("axis") + nvalues = cf_rimage (Memc[fname], axis, x, y, w, weighting, + datatype) + call gt_sets (gt, GTTYPE, "line") + } else { + nvalues = cf_rlist (Memc[fname], x, y, w, weighting, datatype) + call gt_sets (gt, GTTYPE, "mark") + + # For list input only, order the input array. The + # rg_ranges package requires an x ordered input array, or else + # points will be excluded from the fit. This test can be + # removed when/if the ordering restriction is removed from + # rg_xranges. Sorted data is required even when no sampling + # is done, as in the default case of sample=*. (ShJ 6-24-88) + + switch (datatype) { + case TY_REAL: + call xt_sort3 (Memr[x], Memr[y], Memr[w], nvalues) + case TY_DOUBLE: + call xt_sort3d (Memd[x], Memd[y], Memd[w], nvalues) + } + } + + # Allow for adding points. + nmax = nvalues + NADD + call realloc (x, nmax, datatype) + call realloc (y, nmax, datatype) + call realloc (w, nmax, datatype) + + call gt_sets (gt, GTTITLE, Memc[fname]) + + switch (datatype) { + case TY_REAL: + call cf_fitr (ic, gt, Memr[x], Memr[y], Memr[w], nvalues, + nmax, Memc[dev], interactive, ofmt, power) + case TY_DOUBLE: + call cf_fitd (ic, gt, Memd[x], Memd[y], Memd[w], nvalues, + nmax, Memc[dev], interactive, ofmt, power) + } + + call flush (STDOUT) + call mfree (x, datatype) + call mfree (y, datatype) + call mfree (w, datatype) + + if (redir) + break + } + + switch (datatype) { + case TY_REAL: + call ic_closer (ic) + case TY_DOUBLE: + call ic_closed (ic) + } + + if (!redir) + call imtclose (fd) + call gt_free (gt) + call sfree (sp) +end + + +define IMAGE_OP 1 +define LIST_OP 2 + +# CF_OPERAND -- Determine whether the operand argument is an image section +# or a list. If the string is STDIN, it is a list; if a subscript is +# present, it is an image; otherwise we must test whether or not it is a +# binary file and make the decision based on that. + +int procedure cf_operand (operand) + +char operand[ARB] # Input list + +int first, last, ip +int access(), strncmp() + +begin + # Strip off any whitespace at the beginning or end of the string. + for (ip=1; IS_WHITE(operand[ip]); ip=ip+1) + ; + first = ip + for (last=ip; operand[ip] != EOS; ip=ip+1) + if (!IS_WHITE(operand[ip])) + last = ip + + if (first == last) + return (LIST_OP) + else if (strncmp (operand[first], "STDIN", 5) == 0) + return (LIST_OP) + else if (operand[last] == ']') + return (IMAGE_OP) + else if (access (operand, 0, TEXT_FILE) == YES) + return (LIST_OP) + else + return (IMAGE_OP) +end + +define SZ_BUF 1000 + +# CF_RLIST -- Read a list of two dimensional data pairs into two type +# datatype arrays in memory. Return pointers to the arrays and a count of the +# number of pixels. + +int procedure cf_rlist (fname, x, y, w, weighting, datatype) + +char fname[ARB] # Name of list file +pointer x # Pointer to x data values (returned) +pointer y # Pointer to y data values (returned) +pointer w # Pointer to weight values (returned) +int weighting # Type of weighting +int datatype # Datatype of x and Y values + +int buflen, n, fd, ncols, lineno +pointer sp, lbuf, ip + +int getline(), nscan(), open() +real cf_divzr(), cfz_divzr() +double cf_divzd(), cfz_divzd() +extern cf_divzr(), cf_divzd() +extern cfz_divzr(), cfz_divzd() +errchk open, sscan, getline, malloc + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + fd = open (fname, READ_ONLY, TEXT_FILE) + + n = 0 + ncols = 0 + lineno = 0 + + while (getline (fd, Memc[lbuf]) != EOF) { + # Skip comment lines and blank lines. + lineno = lineno + 1 + if (Memc[lbuf] == '#') + next + for (ip=lbuf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == '\n' || Memc[ip] == EOS) + next + + if (n == 0) { + buflen = SZ_BUF + iferr { + call malloc (x, buflen, datatype) + call malloc (y, buflen, datatype) + call malloc (w, buflen, datatype) + } then + call erract (EA_FATAL) + } else if (n + 1 > buflen) { + buflen = buflen + SZ_BUF + call realloc (x, buflen, datatype) + call realloc (y, buflen, datatype) + call realloc (w, buflen, datatype) + } + + # Decode the points to be plotted. + call sscan (Memc[ip]) + switch (datatype) { + case TY_REAL: + call gargr (Memr[x+n]) + call gargr (Memr[y+n]) + call gargr (Memr[w+n]) + case TY_DOUBLE: + call gargd (Memd[x+n]) + call gargd (Memd[y+n]) + call gargd (Memd[w+n]) + } + + # The first line determines whether we have an x,y list or a + # y-list. It is an error if only one value can be decoded when + # processing a two column list. + + if (ncols == 0 && nscan() > 0) + ncols = nscan() + + switch (nscan()) { + case 0: + call eprintf ("no args; %s, line %d: %s\n") + call pargstr (fname) + call pargi (lineno) + call pargstr (Memc[lbuf]) + next + case 1: + if (ncols >= 2) { + call eprintf ("only 1 arg; %s, line %d: %s\n") + call pargstr (fname) + call pargi (lineno) + call pargstr (Memc[lbuf]) + next + } else { + switch (datatype) { + case TY_REAL: + Memr[y+n] = Memr[x+n] + Memr[x+n] = n + 1.0 + Memr[w+n] = 1.0 + case TY_DOUBLE: + Memd[y+n] = Memd[x+n] + Memd[x+n] = n + 1.0 + Memd[w+n] = 1.0d0 + } + } + case 2: + if (ncols == 3) { + call eprintf ("only 2 args; %s, line %d: %s\n") + call pargstr (fname) + call pargi (lineno) + call pargstr (Memc[lbuf]) + next + } else { + switch (datatype) { + case TY_REAL: + Memr[w+n] = 1.0 + case TY_DOUBLE: + Memd[w+n] = 1.0d0 + } + } + } + + n = n + 1 + } + + call realloc (x, n, datatype) + call realloc (y, n, datatype) + call realloc (w, n, datatype) + + switch (weighting) { + case CF_UNIFORM: + if (datatype == TY_REAL) + call amovkr (1.0, Memr[w], n) + else + call amovkd (1.0d0, Memd[w], n) + case CF_USER: + ; + case CF_STATISTICAL: + if (datatype == TY_REAL) { + call aabsr (Memr[y], Memr[w], n) + call arczr (1.0, Memr[w], Memr[w], n, cf_divzr) + } else { + call aabsd (Memd[y], Memd[w], n) + call arczd (1.0d0, Memd[w], Memd[w], n, cf_divzd) + } + case CF_INSTRUMENTAL: + if (datatype == TY_REAL) { + call apowkr (Memr[w], 2, Memr[w], n) + call arczr (1.0, Memr[w], Memr[w], n, cfz_divzr) + } else { + call apowkd (Memd[w], 2, Memd[w], n) + call arczd (1.0d0, Memd[w], Memd[w], n, cfz_divzd) + } + } + + call close (fd) + call sfree (sp) + return (n) +end + + +# CF_RIMAGE -- Read an image section and compute the projection about +# one dimension, producing x and y vectors as output. + +int procedure cf_rimage (imsect, axis, x, y, w, weighting, datatype) + +char imsect[ARB] # Name of image section +pointer x # Pointer to x data values +pointer y # Pointer to y data values +pointer w # Pointer to weight values +int weighting # Type of weighting +int axis # Axis about which projection is taken +int datatype # Datatype of data values + +int npix +pointer im +pointer immap() +errchk immap, im_projectionr, im_projectiond, malloc + +begin + im = immap (imsect, READ_ONLY, 0) + + if (axis < 1 || axis > IM_NDIM(im)) + call error (2, "Attempt to take projection over nonexistent axis") + npix = IM_LEN(im,axis) + + call malloc (x, npix, datatype) + call malloc (y, npix, datatype) + call malloc (w, npix, datatype) + + switch (datatype) { + case TY_REAL: + call im_projectionr (im, Memr[x], Memr[y], Memr[w], npix, weighting, + axis) + case TY_DOUBLE: + call im_projectiond (im, Memd[x], Memd[y], Memd[w], npix, weighting, + axis) + } + + call imunmap (im) + return (npix) +end + + +# CF_DIVZR -- Procedure to return a real number in case of a divide by zero. + +real procedure cf_divzr (a) + +real a # real number + +begin + return (a) +end + + +# CF_DIVZD -- Procedure to return a double number in case of a divide by zero. + +double procedure cf_divzd (a) + +double a # double precision number number + +begin + return (a) +end + + +# CFZ_DIVZR -- Procedure to return a real number in case of a divide by zero. + +real procedure cfz_divzr (a) + +real a # real number + +begin + return (0.0) +end + + +# CFZ_DIVZD -- Procedure to return a double number in case of a divide by zero. + +double procedure cfz_divzd (a) + +double a # double precision number number + +begin + return (0.0d0) +end diff --git a/pkg/utilities/t_detab.x b/pkg/utilities/t_detab.x new file mode 100644 index 00000000..6928b0b8 --- /dev/null +++ b/pkg/utilities/t_detab.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# DETAB -- Each file matching the file template is copied to the standard +# output, replacing tab characters by equivalent sequences of blanks. +# A special list of tabstops may optionally be specified. + +procedure t_detab () + +char tablist[SZ_LINE], line[SZ_LINE], outline[SZ_LINE], in_fname[SZ_FNAME] +int list, nchars, in, tabs[SZ_LINE] +int clpopni(), decode_tablist(), clgfil(), getline() +int gstrdetab(), open() + +begin + list = clpopni ("files") + call clgstr ("tablist", tablist, SZ_LINE) + if (decode_tablist (tablist, tabs, SZ_LINE) == ERR) + call error (1, "Unable to decode list of tabs.") + + while (clgfil (list, in_fname, SZ_FNAME) != EOF) { + in = open (in_fname, READ_ONLY, TEXT_FILE) + while (getline (in, line) != EOF) { + nchars = gstrdetab (line, outline, SZ_LINE, tabs) + call putline (STDOUT, outline) + } + call close (in) + } + + call clpcls (list) +end diff --git a/pkg/utilities/t_entab.x b/pkg/utilities/t_entab.x new file mode 100644 index 00000000..f0bc977e --- /dev/null +++ b/pkg/utilities/t_entab.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ENTAB -- Given a list of files and a list of tabstops, replace sequences +# of blanks in the files by equivalent sequences of tab characters and blanks. + +procedure t_entab() + +char tablist[SZ_LINE], line[SZ_LINE], outline[SZ_LINE] +char in_fname[SZ_FNAME] +int list, in, nchars + +int clpopni(), decode_tablist(), tabs[SZ_LINE], clgfil(), getline() +int gstrentab(), open() + +begin + list = clpopni ("files") + call clgstr ("tablist", tablist, SZ_LINE) + if (decode_tablist (tablist, tabs, SZ_LINE) == ERR) + call error (1, "Unable to decode list of tabs.") + + while (clgfil (list, in_fname, SZ_FNAME) != EOF) { + in = open (in_fname, READ_ONLY, TEXT_FILE) + while (getline (in, line) != EOF) { + nchars = gstrentab (line, outline, SZ_LINE, tabs) + call putline (STDOUT, outline) + } + call close (in) + } + + call clpcls (list) +end diff --git a/pkg/utilities/t_lcase.x b/pkg/utilities/t_lcase.x new file mode 100644 index 00000000..93aab6a5 --- /dev/null +++ b/pkg/utilities/t_lcase.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# LCASE -- Convert the standard input or a list of files to lower case. + +procedure t_lcase() + +pointer sp, line, in_file, out_file +int list, in, out +bool strne() +int open(), clpopni(), clgfil(), getline(), clplen() + +begin + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + call salloc (in_file, SZ_FNAME, TY_CHAR) + call salloc (out_file, SZ_FNAME, TY_CHAR) + + list = clpopni ("files") + + # Multiple files are converted to files of the same name with the + # extension ".lc". + + while (clgfil (list, Memc[in_file], SZ_FNAME) != EOF) { + in = open (Memc[in_file], READ_ONLY, TEXT_FILE) + if (clplen (list) > 1 && strne (Memc[in_file], "STDIN")) { + call strcpy (Memc[in_file], Memc[out_file], SZ_FNAME) + call strcat (".lc", Memc[out_file], SZ_FNAME) + } else + call strcpy ("STDOUT", Memc[out_file], SZ_FNAME) + out = open (Memc[out_file], NEW_FILE, TEXT_FILE) + + while (getline (in, Memc[line]) != EOF) { + call strlwr (Memc[line]) + call putline (out, Memc[line]) + } + call close (in) + call close (out) + } + + call clpcls (list) + call sfree (sp) +end diff --git a/pkg/utilities/t_polyfit.x b/pkg/utilities/t_polyfit.x new file mode 100644 index 00000000..003935ee --- /dev/null +++ b/pkg/utilities/t_polyfit.x @@ -0,0 +1,244 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define POLY_INSTRUMENTAL 1 +define POLY_UNIFORM 2 +define POLY_STATISTICAL 3 + +define MAX_ITEMS 1000 # maximum number of data elements + +# POLYFIT -- Fit a polynomial to the list of input pairs (x,y, sigmay) +# A polynomial fit of user specifiable order is made to the data. +# +# y = a0 + a1*x + a2*x**2 + ... +# +# The values for the coeficients a0 - aN are printed on the +# first line of the standard output. The uncertainties in the +# coeficients are then printed on the next line. +# +# Optionally (verbose = yes) the values for chi-square, ftest, +# and correlation coefficient are printed along with the calculated +# values from the fit for the dependent variable. +# +# If listdata = yes, then the only output will be pairs of +# X,Yc values. Yc is the value of dependent variable as Calculated +# from the fit. This option allows piping to the GRAPH task. +# +# The data are taken from STDIN, a file, or a list of files. +# In the latter case, each data file results in an independent +# set of results. + +# The routines REGRES and MATINV from Bevington are used to perfrom +# the fit. + +procedure t_polyfit() + +char fname[SZ_FNAME], weights[SZ_FNAME] +bool verbose, listdata +int filelist, order, weighting +int clpopni(), clgfil(), clgeti(), clgwrd() +bool clgetb() +define exit_ 91 + +begin + # Input can come from the standard input, a file, or a list of files. + # The following procedure makes both cases look like a list of files. + + filelist = clpopni ("input") + order = clgeti ("order") + weighting = clgwrd ("weighting", weights, SZ_FNAME, + ",instrumental,uniform,statistical,") + verbose = clgetb ("verbose") + listdata = clgetb ("listdata") + + while (clgfil (filelist, fname, SZ_FNAME) != EOF) + call pf_fitdatalist (fname, order, weighting, verbose, listdata) + + call clpcls (filelist) +end + + +# PF_FITDATALIST -- Perform polynomial fit to data from named file. + +procedure pf_fitdatalist (listfile, order, weighting, verbose, listdata) + +char listfile[SZ_FNAME] # input file +int order # polynomial order +int weighting # mode of weighting fit +bool verbose, listdata # printout options + +int i, in, item, m[50], mode, nterms, line_number +real x[MAX_ITEMS], y[MAX_ITEMS], yfit[MAX_ITEMS], sigy[MAX_ITEMS] +real a0, a[50], siga0, siga[50], r[50], rmul, chisqr, ftest +real stdev + +extern pf_fctn() +bool fp_equalr() +int fscan(), nscan(), open() +errchk open, fscan, printf + +begin + # Set term selection array for REGRES. + for (i=1; i <= 50; i=i+1) + m[i] = i + + in = open (listfile, READ_ONLY, TEXT_FILE) + + # Read successive X,Y, SIGMAY triples from the standard input, + # accumulating the values in the arrays X, Y, weight. Skip list + # elements containing less than two numbers. The maximum number of + # elements that can be read is fixed. + + item = 1 + line_number = 0 + + while ((fscan (in) != EOF) && (item < MAX_ITEMS+1)) { + line_number = line_number + 1 + + call gargr (x[item]) + call gargr (y[item]) + + # There must be two items per entry for the x,y pair. + if (nscan() < 2) { + call eprintf ("Bad entry in list on line:%d - item ignored\n") + call pargi (line_number) + next + } + + # Set undefined errors to 0.0. + if (weighting == POLY_INSTRUMENTAL) { + call gargr (sigy[item]) + if (nscan() < 3) { + call eprintf ("Undefined sigmay on line:%d - item ignored\n") + call pargi (line_number) + next + } else if (fp_equalr (sigy[item], 0.0)) { + call eprintf ("Zero-valued sigmay on line:%d - item ignored\n") + call pargi (line_number) + next + } + + } else + sigy[item] = 0 + + item = item + 1 + } + + item = item - 1 + if (item > MAX_ITEMS) { + call printf ("Number of data elements exceeded - max=%d\n") + call pargi (MAX_ITEMS) + } + + if (item <= order) { + call eprintf ("Not enough data for fit: order=%d, items=%d\n") + call pargi (order) + call pargi (item) + goto exit_ + } + + # It is necessary to scale the dependent variable values + # to 1.0 on average to minimize the dynamic range during + # matrix inversion. + + nterms = order + switch (weighting) { + case POLY_INSTRUMENTAL: + mode = 1 + case POLY_UNIFORM: + mode = 0 + case POLY_STATISTICAL: + mode = -1 + default: + mode = 0 + } + + call pf_regres (x, y, sigy, item, nterms, m, mode, yfit, + a0, a, siga0, siga, r, rmul, chisqr, ftest, pf_fctn) + + # Compute standard deviation of residuals from reduced chi-sqr. + switch (weighting) { + case POLY_STATISTICAL, POLY_INSTRUMENTAL: + stdev = 0.0 + do i = 1, item + stdev = stdev + (y[i] - yfit[i]) ** 2 + stdev = sqrt (stdev / (item - 1)) + case POLY_UNIFORM: + stdev = sqrt ((item - nterms - 1) * chisqr / (item - 1)) + default: + stdev = sqrt ((item - nterms - 1) * chisqr / (item - 1)) + } + + # Print coefficients scaled back to input Y levels + if (!listdata) { + call printf ("%12.7g") + call pargr (a0) + + for (i=1; i <= order; i=i+1) { + call printf (" %12.7g") + call pargr (a[i]) + } + call printf ("\n") + + # Print sigmas. + call printf ("%12.7g") + call pargr (siga0) + + for (i=1; i <= order; i=i+1) { + call printf (" %12.7g") + call pargr (siga[i]) + } + call printf ("\n") + + # If verbose option specified, also print chi-square, ftest + # correlation coefficient, standard deviation of residuals, + # number of input pairs, and calculated y-values. + # ***25Nov85,SeH - ftest is undefined when correlation = 1. + + if (verbose) { + + if (fp_equalr (ftest, -99999.)) { + call printf ("\nchi sqr: %7g ftest: UNDEF ") + call pargr (chisqr) + if (fp_equalr (rmul, -99999.)) { + call printf (" correlation: UNDEF\n") + call pargr (rmul) + } else { + call printf (" correlation: %7g\n") + call pargr (rmul) + } + } else { + call printf ("\nchi sqr: %7g ftest: %7g ") + call pargr (chisqr) + call pargr (ftest) + if (fp_equalr (rmul, -99999.)) { + call printf (" correlation: UNDEF\n") + call pargr (rmul) + } else { + call printf ("correlation: %7g\n") + call pargr (rmul) + } + } + + call printf (" nr pts: %7g std dev res: %0.6g\n") + call pargi (item) + call pargr (stdev) + + call printf ("\nx(data) y(calc) y(data) sigy(data)\n") + } + } + + if (verbose || listdata) { + for (i=1; i <= item; i=i+1) { + call printf ("%7g %7g %7g %7g\n") + call pargr (x[i]) + call pargr (yfit[i]) + call pargr (y[i]) + call pargr (sigy[i]) + } + } + +exit_ + call close (in) +end diff --git a/pkg/utilities/t_split.x b/pkg/utilities/t_split.x new file mode 100644 index 00000000..11d2d5cb --- /dev/null +++ b/pkg/utilities/t_split.x @@ -0,0 +1,108 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# SPLIT -- Split a large file up into more manageable pieces. If the operand +# is a text file, split the file into segments of at most NLINES lines, else +# if the file is a binary file, split it into segments of at most NBYTES bytes. +# Only a single input file can be processed. + +procedure t_split() + +long offset +bool verbose +pointer sp, input, output, fname, buf +int maxfiles, nchars, nlines, nbytes +int file_type, nrecords, fileno, in, out, n + +bool clgetb() +int open(), read(), getline(), access(), clgeti() + +begin + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Get the input file name and the root name for the output files. + call clgstr ("input", Memc[input], SZ_FNAME) + call clgstr ("output", Memc[output], SZ_FNAME) + + # Determine the file type of the input file. + if (access (Memc[input], READ_ONLY, TEXT_FILE) == YES) + file_type = TEXT_FILE + else + file_type = BINARY_FILE + + # Determine the segment size and allocate the data buffer. + if (file_type == TEXT_FILE) { + nlines = clgeti ("nlines") + call salloc (buf, SZ_LINE, TY_CHAR) + } else { + nbytes = clgeti ("nbytes") + nchars = (nbytes + SZB_CHAR-1) / SZB_CHAR + call salloc (buf, nchars, TY_CHAR) + } + + maxfiles = clgeti ("maxfiles") + verbose = clgetb ("verbose") + + # Split the input file. + in = open (Memc[input], READ_ONLY, file_type) + offset = 1 + + for (fileno=1; fileno <= maxfiles; fileno=fileno+1) { + # Open the next segment file. + call sprintf (Memc[fname], SZ_FNAME, "%s.%0*d") + call pargstr (Memc[output]) + call pargi (int (log10(real(maxfiles))) + 1) + call pargi (fileno) + + if (verbose) { + call printf ("%s: ") + call pargstr (Memc[fname]) + call flush (STDOUT) + } + out = open (Memc[fname], NEW_FILE, file_type) + + # Copy the segment. + if (file_type == BINARY_FILE) { + n = read (in, Memc[buf], nchars) + if (n != EOF) { + call write (out, Memc[buf], n) + nrecords = n + } else + nrecords = 0 + } else { + for (nrecords=0; nrecords < nlines; nrecords=nrecords+1) + if (getline (in, Memc[buf]) == EOF) + break + else + call putline (out, Memc[buf]) + } + + # Close the file; delete it and exit if no data was written. + call close (out) + if (nrecords <= 0) { + if (verbose) + call printf ("[deleted; exit]\n") + call delete (Memc[fname]) + break + } else if (verbose) { + call printf ("%d %s @ %d\n") + if (file_type == TEXT_FILE) { + call pargi (nrecords) + call pargstr ("lines") + } else { + call pargi (nrecords * SZB_CHAR) + call pargstr ("bytes") + } + call pargi (offset) + } + + offset = offset + nrecords + call flush (STDOUT) + } + + call sfree (sp) +end diff --git a/pkg/utilities/t_surfit.x b/pkg/utilities/t_surfit.x new file mode 100644 index 00000000..3415b9e5 --- /dev/null +++ b/pkg/utilities/t_surfit.x @@ -0,0 +1,342 @@ +include +include +include + + +# T_SURFIT -- Fit a surface to a set of x, y, and z points from an input +# text file. Output the surface parameters, coefficients, errors, data +# points with fit and residuals, and chi square to the standard output. +# Optionally evaluate the surface for a set of x and y from a text file and +# write x, y, and z to an output text file. Optionally evaluate the surface +# over the fit limits and create an image with appropriate WCS. + +procedure t_surfit () + +pointer input # Input file +pointer func # Function type +pointer wttype # Weight type +pointer image # Surface image +pointer coords # Coordinates to evaluate +pointer fit # Fit output file +int xorder # X order +int yorder # Y order +int xterms # Cross-terms? +double xmin, xmax # Surface range +double ymin, ymax # Surface range +double zmin, zmax # Data limits +int ncols # Number of image columns +int nlines # Number of image lines + +int i, j, k, fd, n, ncoeff, maxorder, xincr +double r[8], dx, dy, chisqr +pointer sf, im, mw +pointer sp, x, y, z, w, c, e, f, xvec, yvec, ptr, xtype + +int clgeti(), clgwrd() +int open(), fscan(), nscan(), nowhite(), dgsgeti() +double clgetd(), dgseval() +pointer immap(), impl2d(), mw_open() +errchk open, malloc, realloc, immap, impl2d, mw_open +errchk dgsinit, dgsfit, dgscoeff, dgserrors + +begin + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (func, SZ_FNAME, TY_CHAR) + call salloc (wttype, SZ_FNAME, TY_CHAR) + call salloc (coords, SZ_FNAME, TY_CHAR) + call salloc (fit, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (xtype, SZ_FNAME, TY_CHAR) + + x = NULL + y = NULL + z = NULL + w = NULL + fd = NULL + sf = NULL + im = NULL + mw = NULL + + iferr { + # Read points to be fit. + call clgstr ("input", Memc[input], SZ_FNAME) + ptr = open (Memc[input], READ_ONLY, TEXT_FILE); fd = ptr + + n = 0 + while (fscan (fd) != EOF) { + call gargd (r[1]) + call gargd (r[2]) + call gargd (r[3]) + call gargd (r[4]) + if (nscan() < 3) + next + if (nscan() < 4) + r[4] = 1. + if (n == 0) { + call malloc (x, 100, TY_DOUBLE) + call malloc (y, 100, TY_DOUBLE) + call malloc (z, 100, TY_DOUBLE) + call malloc (w, 100, TY_DOUBLE) + } else if (mod (n, 100) == 0) { + call realloc (x, n+100, TY_DOUBLE) + call realloc (y, n+100, TY_DOUBLE) + call realloc (z, n+100, TY_DOUBLE) + call realloc (w, n+100, TY_DOUBLE) + } + Memd[x+n] = r[1] + Memd[y+n] = r[2] + Memd[z+n] = r[3] + Memd[w+n] = r[4] + n = n + 1 + } + call close (fd) + if (n == 0) + call error (1, "No points") + + # Set x, y, z limits and reject data outside range. + xmin = clgetd ("xmin") + xmax = clgetd ("xmax") + ymin = clgetd ("ymin") + ymax = clgetd ("ymax") + zmin = clgetd ("zmin") + zmax = clgetd ("zmax") + call alimd (Memd[x], n, dx, dy) + if (IS_INDEFD(xmin)) + xmin = dx + if (IS_INDEFD(xmax)) + xmax = dy + call alimd (Memd[y], n, dx, dy) + if (IS_INDEFD(ymin)) + ymin = dx + if (IS_INDEFD(ymax)) + ymax = dy + call alimd (Memd[z], n, dx, dy) + if (IS_INDEFD(zmin)) + zmin = dx + if (IS_INDEFD(zmax)) + zmax = dy + j = 0 + do i = 0, n-1 { + if (Memd[x+i] < xmin || Memd[x+i] > xmax) + next + if (Memd[y+i] < ymin || Memd[y+i] > ymax) + next + if (Memd[z+i] < zmin || Memd[z+i] > zmax) + next + Memd[x+j] = Memd[x+i] + Memd[y+j] = Memd[y+i] + Memd[z+j] = Memd[z+i] + Memd[w+j] = Memd[w+i] + j = j + 1 + } + n = j + if (n == 0) + call error (2, "No data values") + + # Fit surface. + i = clgwrd ("function", Memc[func], SZ_FNAME, GS_FUNCTIONS) + xorder = clgeti ("xorder") + yorder = clgeti ("yorder") + xterms = clgwrd ("xterms", Memc[xtype], SZ_FNAME, GS_XTYPES) - 1 + + # Set the weights. + j = clgwrd ("weighting", Memc[wttype], SZ_FNAME, + "|uniform|user|statistical|instrumental|") + switch (j) { + case 1: + do k = 0, n-1 + Memd[w+k] = 1 + case 2: + ; + case 3: + do k = 0, n-1 + Memd[w+k] = 1 / max (1.0d-20, abs (Memd[z+k])) + case 4: + do k = 0, n-1 + Memd[w+k] = 1 / max (1.0d-20, Memd[z+k]**2) + } + + call dgsinit (sf, i, xorder, yorder, xterms, xmin, xmax, ymin, ymax) + call dgsfit (sf, Memd[x], Memd[y], Memd[z], Memd[w], n, WTS_USER, i) + if (i != OK) + call error (2, "Fitting error") + + # Output parameters, coefficients, errors, and fit results. + ncoeff = dgsgeti (sf, GSNCOEFF) + call salloc (c, ncoeff, TY_DOUBLE) + call salloc (e, ncoeff, TY_DOUBLE) + call salloc (f, n, TY_DOUBLE) + call dgscoeff (sf, Memd[c], ncoeff) + call dgsvector (sf, Memd[x], Memd[y], Memd[f], n) + call dgserrors (sf, Memd[z], Memd[w], Memd[f], chisqr, Memd[e]) + + call printf ("Surface parameters:\n") + call printf (" function = %s\n") + call pargstr (Memc[func]) + call printf (" xorder = %d\n yorder = %d\n xterms = %s\n") + call pargi (xorder) + call pargi (yorder) + call pargstr (Memc[xtype]) + call printf (" weighting = %s\n") + call pargstr (Memc[wttype]) + call printf (" xmin = %8.6g\n xmax = %8.6g\n") + call pargd (xmin) + call pargd (xmax) + call printf (" ymin = %8.6g\n ymax = %8.6g\n") + call pargd (ymin) + call pargd (ymax) + call printf (" zmin = %8.6g\n zmax = %8.6g\n") + call pargd (zmin) + call pargd (zmax) + + call printf ("\nSurface coefficients:\n") + call printf (" x y coeff error\n") + i = 0 + if (xterms == GS_XFULL) { + do k = 1, yorder { + do j = 1, xorder { + call printf (" %2d %2d %8.6g %8.6g\n") + call pargi (j-1) + call pargi (k-1) + call pargd (Memd[c+i]) + call pargd (Memd[e+i]) + i = i + 1 + } + } + } else if (xterms == GS_XHALF) { + maxorder = max (xorder+1, yorder+1) + xincr = xorder + do k = 1, yorder { + do j = 1, xincr { + call printf (" %2d %2d %8.6g %8.6g\n") + call pargi (j-1) + call pargi (k-1) + call pargd (Memd[c+i]) + call pargd (Memd[e+i]) + i = i + 1 + } + if ((k + xorder + 1) > maxorder) + xincr = xincr - 1 + } + } else { + do j = 1, xorder { + call printf (" %2d %2d %8.6g %8.6g\n") + call pargi (j-1) + call pargi (0) + call pargd (Memd[c+i]) + call pargd (Memd[e+i]) + i = i + 1 + } + do k = 2, yorder { + call printf (" %2d %2d %8.6g %8.6g\n") + call pargi (0) + call pargi (k-1) + call pargd (Memd[c+i]) + call pargd (Memd[e+i]) + i = i + 1 + } + } + + call printf ("\nFitted points:\n") + call printf (" %8s %8s %8s %8s %8s %8s\n") + call pargstr ("x") + call pargstr ("y") + call pargstr ("z") + call pargstr ("fit") + call pargstr ("residual") + call pargstr ("weight") + do i = 0, n-1 { + call printf (" %8.6g %8.6g %8.6g %8.6g %8.6g %8.6g\n") + call pargd (Memd[x+i]) + call pargd (Memd[y+i]) + call pargd (Memd[z+i]) + call pargd (Memd[f+i]) + call pargd (Memd[z+i] - Memd[f+i]) + call pargd (Memd[w+i]) + } + call printf ("\n chisqr = %8.6g\n") + call pargd (chisqr) + + # Evaluate surface if desired. + call clgstr ("coordinates", Memc[coords], SZ_FNAME) + if (nowhite (Memc[coords], Memc[coords], SZ_FNAME) != 0) { + ptr = open (Memc[coords], READ_ONLY, TEXT_FILE); fd = ptr + + call clgstr ("fit", Memc[fit], SZ_FNAME) + if (nowhite (Memc[fit], Memc[fit], SZ_FNAME) != 0) { + i = open (Memc[fit], APPEND, TEXT_FILE) + while (fscan (fd) != EOF) { + call gargd (r[1]) + call gargd (r[2]) + if (nscan() < 2) + next + if (r[1]xmax || r[2]ymax) + next + r[3] = dgseval (sf, r[1], r[2]) + call fprintf (i, "%8.6g %8.6g %8.6g\n") + call pargd (r[1]) + call pargd (r[2]) + call pargd (r[3]) + } + call close (i) + } + call close (fd) + } + + # Create an image if desired. + call clgstr ("image", Memc[image], SZ_FNAME) + if (nowhite (Memc[image], Memc[image], SZ_FNAME) != 0) { + ncols = clgeti ("ncols") + nlines = clgeti ("nlines") + + ptr = immap (Memc[image], NEW_IMAGE, 0); im = ptr + IM_PIXTYPE(im) = TY_REAL + IM_LEN(im,1) = ncols + IM_LEN(im,2) = nlines + + call salloc (xvec, ncols, TY_DOUBLE) + call salloc (yvec, ncols, TY_DOUBLE) + dx = (xmax - xmin) / (ncols - 1) + dy = (ymax - ymin) / (nlines - 1) + do i = 1, ncols + Memd[xvec+i-1] = xmin + dx * (i - 1) + do i = 1, nlines { + Memd[yvec] = ymin + dy * (i - 1) + call amovkd (Memd[yvec], Memd[yvec], ncols) + call dgsvector (sf, Memd[xvec], Memd[yvec], + Memd[impl2d(im,i)], ncols) + } + + r[1] = 1. + r[2] = 1. + r[3] = xmin + r[4] = ymin + r[5] = dx + r[6] = 0. + r[7] = 0. + r[8] = dy + mw = mw_open (NULL, 2) + call mw_newsystem (mw, "world", 2) + call mw_swtermd (mw, r[1], r[3], r[5], 2) + call mw_saveim (mw, im) + + call mw_close (mw) + call imunmap (im) + } + + call dgsfree (sf) + } then { + if (fd != NULL) + call close (fd) + if (mw != NULL) + call mw_close (mw) + if (im != NULL) + call imunmap (im) + if (sf != NULL) + call dgsfree (sf) + call erract (EA_WARN) + } + + call sfree (sp) +end diff --git a/pkg/utilities/t_translit.x b/pkg/utilities/t_translit.x new file mode 100644 index 00000000..ac7a9aca --- /dev/null +++ b/pkg/utilities/t_translit.x @@ -0,0 +1,294 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# TRANSLIT -- Copy a file or files, replacing specified characters by +# other characters, or deleting specified characters. + +define NCHARS 128 +define ON 1 +define OFF 0 + +procedure t_translit() + +char from_string[NCHARS], to_string[NCHARS] + +char to[NCHARS], from[NCHARS], lut[NCHARS], infile[SZ_FNAME], endto +char line[SZ_LINE], lastchar +int del[NCHARS], collap[NCHARS] +int list, delete, allbut, lastfrom, lastto, collapse, in, i, op, nchars + +bool clgetb() +int clpopni(), makeset(), strlen(), clgfil(), open(), getline() + +begin + call fseti (STDOUT, F_FLUSHNL, YES) + list = clpopni ("infile") + + # Make from and to character sets + call clgstr ("from_string", from_string, NCHARS) + if (from_string[1] == CH_NOT) { + allbut = YES + if (makeset (from_string, 2, from, NCHARS) == ERR) + call error (1, "From_string too large.") + } else { + allbut = NO + if (makeset (from_string, 1, from, NCHARS) == ERR) + call error (2, "From_string too large.") + } + + if (clgetb ("delete")) { + delete = YES + to[1] = EOS + } else { + delete = NO + call clgstr ("to_string", to_string, NCHARS) + if (makeset (to_string, 1, to, NCHARS) == ERR) + call error (3, "To_string too large.") + } + + lastfrom = strlen (from) + lastto = strlen (to) + endto = to[lastto] + + # Expand to set + if (delete == NO) { + for (i = lastto + 1; i <= NCHARS; i = i + 1) + to[i] = endto + to[i] = EOS + } + + # Collapse data ? + if (delete == YES) { + collapse = NO + } else if (allbut == YES) { + collapse = YES + } else if (lastfrom > lastto) { + if (! clgetb ("collapse")) + collapse = NO + else + collapse = YES + } else { + collapse = NO + } + + # Set up transformations + + # Initialize lookup table, delete and collapse vectors + call makelut (lut, NCHARS) + call amovki (OFF, del, NCHARS) + call amovki (OFF, collap, NCHARS) + + # Delete array + if (delete == YES) { + do i = 1, lastfrom + del[from[i] + 1] = ON + } + + # Collapse array + do i = 1, lastfrom + collap[from[i] + 1] = ON + + # Allbut? + if (allbut == YES) { + if (delete == YES) + call axorki (del, ON, del, NCHARS) + call axorki (collap, ON, collap, NCHARS) + } + + # Set up the transformation + if (delete == NO) { + op = 1 + do i = 1, NCHARS { + if (collap[i] == ON) { + lut[i] = to[op] + op = op + 1 + } + } + } + + # Loop over the files + while (clgfil (list, infile, SZ_FNAME) != EOF) { + + in = open (infile, READ_ONLY, TEXT_FILE) + lastchar = EOF + + repeat { + + nchars = getline (in, line) + if (nchars == EOF) + break + op = 1 + + if (delete == YES) { + call del_line (line, line, nchars, op, lut, del) + } else if (collapse == YES) { + call col_line (line, line, nchars, op, lut, collap, endto, + lastchar) + } else { + call map_line (line, line, nchars, op, lut) + } + + call putline (STDOUT, line) + + } + call close (in) + } + + call clpcls (list) +end + + +# MAKESET -- Procedure to make to and from character sets. + +int procedure makeset (array, k, set, size) + +char array[ARB], set[ARB] +int k, size + +int i, j + +begin + i = k + j = 1 + + call filset ("", array, i, set, j, size) + call chdeposit ("", set, size + 1, j) + + if (j > size + 1) + return (ERR) + else + return (OK) +end + + +# FILSET -- Process a character class into a simple list of characters. + +procedure filset (delim, patstr, ip, patbuf, op, sz_pat) + +char patstr[ARB], delim, patbuf[ARB] +int ip, sz_pat, op +char ch, ch1, ch2 +int cctoc() + +begin + for (; patstr[ip] != delim && patstr[ip] != EOS; ip=ip+1) { + if (patstr[ip] == ESCAPE) { # escape seq. + if (cctoc (patstr, ip, ch) == 1) + ch = patstr[ip] + else + ip = ip - 1 + call chdeposit (ch, patbuf, sz_pat, op) + + } else if (patstr[ip] != CH_RANGE) { + call chdeposit (patstr[ip], patbuf, sz_pat, op) + + } else if (op <= 1 || patstr[ip+1] == EOS) { # literal "-" + ch = CH_RANGE + call chdeposit (ch, patbuf, sz_pat, op) + + # Here if char is CH_RANGE, denoting a range of characters to + # be included in the character class. Range is valid only if + # limit chars are both digits, both lower case, or both upper case. + + } else { + ch1 = patbuf[op-1] # not same as patstr[ip-1] + ch2 = patstr[ip+1] + + if ((IS_DIGIT (ch1) && IS_DIGIT (ch2)) || + (IS_LOWER (ch1) && IS_LOWER (ch2)) || + (IS_UPPER (ch1) && IS_UPPER (ch2))) { + if (ch1 <= ch2) + for (ch=ch1+1; ch <= ch2; ch=ch+1) + call chdeposit (ch, patbuf, sz_pat, op) + else + for (ch=ch1-1; ch >= ch2; ch=ch-1) + call chdeposit (ch, patbuf, sz_pat, op) + ip = ip + 1 + } else { + ch = CH_RANGE + call chdeposit (ch, patbuf, sz_pat, op) + } + } + } +end + + +# MAKELUT -- Make lookup table + +procedure makelut (lut, nchars) + +char lut[ARB] +int nchars + +int i + +begin + do i = 1, nchars + lut[i] = char (i - 1) +end + + +# DEL_LINE -- Procedure to delete characters from a line + +procedure del_line (inline, outline, nchars, op, lut, delete) + +char inline[ARB], outline[ARB], lut[ARB] +int nchars, op, delete[ARB] + +int i + +begin + do i = 1, nchars { + if (delete[inline[i] + 1] == OFF) { + outline[op] = lut[inline[i] + 1] + op = op + 1 + } + } + outline[op] = EOS +end + + +# MAP_LINE -- Procedure to map a line + +procedure map_line (inline, outline, nchars, op, lut) + +char inline[ARB], outline[ARB], lut[ARB] +int nchars, op + +int i + +begin + do i = 1, nchars { + outline[op] = lut[inline[i] + 1] + op = op + 1 + } + outline[op] = EOS +end + + +# COL_LINE -- Procedure to collapse line + +procedure col_line (inline, outline, nchars, op, lut, collap, endto, lastchar) + +char inline[ARB], outline[ARB], lut[ARB], endto, lastchar +int nchars, op, collap[ARB] + +int i + +begin + do i = 1, nchars { + if (collap[inline[i] +1] == ON && lut[inline[i] + 1] == endto && + lastchar == endto) { + ; + } else { + outline[op] = lut[inline[i] + 1] + op = op + 1 + } + lastchar = lut[inline[i] + 1] + } + outline[op] = EOS +end diff --git a/pkg/utilities/t_ucase.x b/pkg/utilities/t_ucase.x new file mode 100644 index 00000000..a7332338 --- /dev/null +++ b/pkg/utilities/t_ucase.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# UCASE -- Convert the standard input or a list of files to upper case. + +procedure t_ucase() + +pointer sp, line, in_file, out_file +int list, in, out +bool strne() +int open(), clpopni(), clgfil(), getline(), clplen() + +begin + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + call salloc (in_file, SZ_FNAME, TY_CHAR) + call salloc (out_file, SZ_FNAME, TY_CHAR) + + list = clpopni ("files") + + # Multiple files are converted to files of the same name with the + # extension ".uc". + + while (clgfil (list, Memc[in_file], SZ_FNAME) != EOF) { + in = open (Memc[in_file], READ_ONLY, TEXT_FILE) + if (clplen (list) > 1 && strne (Memc[in_file], "STDIN")) { + call strcpy (Memc[in_file], Memc[out_file], SZ_FNAME) + call strcat (".uc", Memc[out_file], SZ_FNAME) + } else + call strcpy ("STDOUT", Memc[out_file], SZ_FNAME) + out = open (Memc[out_file], NEW_FILE, TEXT_FILE) + + while (getline (in, Memc[line]) != EOF) { + call strupr (Memc[line]) + call putline (out, Memc[line]) + } + call close (in) + call close (out) + } + + call clpcls (list) + call sfree (sp) +end diff --git a/pkg/utilities/t_urand.x b/pkg/utilities/t_urand.x new file mode 100644 index 00000000..2cf7a7b2 --- /dev/null +++ b/pkg/utilities/t_urand.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# URAND -- Uniform random number generator. Write a list of random numbers +# to the standard output. The number of columns per line of output and the +# number of significant digits in each number are parameterized. + +procedure t_urand() + +int nlines # number of lines of output +int ncols # number of random numbers per line +int ndigits # number of digits of precision +long seed # seed for the random number generator +real scale_factor # scale output numbers by this factor + +int n, i +long seed1 +int clgeti() +long clgetl(), clktime() +real clgetr(), urand() + +begin + # Get parameters from the CL. + nlines = clgeti ("nlines") + ncols = clgeti ("ncols") + ndigits = clgeti ("ndigits") + seed = clgetl ("seed") + scale_factor = clgetr ("scale_factor") + + # Compute the random numbers and print on the standard output as + # a list, "ncols" numbers per output line. The output format + # is dependent on the ndigits of precision, set by the user. + + if (IS_INDEFL(seed)) + seed1 = seed1 + clktime (long(0)) + else + seed1 = seed + + for (n=1; n <= nlines; n=n+1) { + do i = 1, ncols { + call printf ("%*.*g ") + call pargi (ndigits + 2) # field width + call pargi (ndigits) # precision + call pargr (urand (seed1) * scale_factor) + } + call printf ("\n") + } +end diff --git a/pkg/utilities/translit.par b/pkg/utilities/translit.par new file mode 100644 index 00000000..d25ae17b --- /dev/null +++ b/pkg/utilities/translit.par @@ -0,0 +1,5 @@ +infile,s,a,,,,input file name(s) +from_string,s,a,,,,set of characters to be replaced or deleted +to_string,s,a,,,,set of characters to be substituted +delete,b,h,no,,,delete chars in from string from input file? +collapse,b,h,no,,,remove repeated characters in output? diff --git a/pkg/utilities/ucase.par b/pkg/utilities/ucase.par new file mode 100644 index 00000000..4a477438 --- /dev/null +++ b/pkg/utilities/ucase.par @@ -0,0 +1 @@ +files,s,a,,,,list of files to be converted to upper case diff --git a/pkg/utilities/urand.par b/pkg/utilities/urand.par new file mode 100644 index 00000000..23302c6a --- /dev/null +++ b/pkg/utilities/urand.par @@ -0,0 +1,5 @@ +nlines,i,a,10,,,number of lines of output to generate +ncols,i,a,1,,,number of random numbers per line +ndigits,i,h,4,1,7,number of digits of precision +seed,i,h,1,,,seed for the random number generator +scale_factor,r,h,1.0,,,scale factor by which numbers are to be multiplied diff --git a/pkg/utilities/utilities.cl b/pkg/utilities/utilities.cl new file mode 100644 index 00000000..183f3cd5 --- /dev/null +++ b/pkg/utilities/utilities.cl @@ -0,0 +1,29 @@ +#{ Package script task for the UTILITIES package. + +set nttools = "utilities$nttools/" + + +package utilities + +task ucase, + lcase, + translit, + detab, + entab, + urand, + polyfit, + curfit, + surfit, + split = "utilities$x_utilities.e" + +# Utility scripts. +task bases = "utilities$bases.cl" + +# Sub-Packages. +task nttools.pkg = nttools$nttools.cl + + +# Load the NTTOOLS package when we are loaded. +nttools + +clbye() diff --git a/pkg/utilities/utilities.hd b/pkg/utilities/utilities.hd new file mode 100644 index 00000000..6bec4696 --- /dev/null +++ b/pkg/utilities/utilities.hd @@ -0,0 +1,26 @@ +# Help directory for the UTILITIES package. + +$defdir = "pkg$utilities/" +$nttools = "pkg$utilities/nttools/" +$doc = "./doc/" + + +nttools men=nttools$nttools.men, + hlp=.., + sys=nttools$nttools.hlp, + pkg=nttools$nttools.hd, + src=nttools$nttools.cl + + +bases hlp=doc$bases.hlp, src=bases.cl +curfit hlp=doc$curfit.hlp, src=t_curfit.x +detab hlp=doc$detab.hlp, src=t_detab.x +entab hlp=doc$entab.hlp, src=t_entab.x +lcase hlp=doc$lcase.hlp, src=t_lcase.x +polyfit hlp=doc$polyfit.hlp, src=t_polyfit.x +revisions sys=Revisions +split hlp=doc$split.hlp, src=t_split.x +surfit hlp=doc$surfit.hlp, src=t_surfit.x +translit hlp=doc$translit.hlp, src=t_translit.x +ucase hlp=doc$ucase.hlp, src=t_ucase.x +urand hlp=doc$urand.hlp, src=t_urand.x diff --git a/pkg/utilities/utilities.men b/pkg/utilities/utilities.men new file mode 100644 index 00000000..6650bc71 --- /dev/null +++ b/pkg/utilities/utilities.men @@ -0,0 +1,13 @@ + bases - Convert an integer to hex, octal, and binary + curfit - Fit data with Chebyshev, Legendre or spline curve + detab - Replace tabs with tabs and blanks + entab - Replace blanks with tabs and blanks + lcase - Convert a file to lower case + polyfit - Fit polynomial to list of X,Y data + split - Split a large file into smaller segments + surfit - Fit a surface, z=f(x,y), to a set of x, y, z points + translit - Replace or delete specified characters in a file + ucase - Convert a file to upper case + urand - Uniform random number generator + + nttools - NOAO version of TTOOLS package diff --git a/pkg/utilities/utilities.par b/pkg/utilities/utilities.par new file mode 100644 index 00000000..9ff60c72 --- /dev/null +++ b/pkg/utilities/utilities.par @@ -0,0 +1 @@ +version,s,h,"4Nov10" diff --git a/pkg/utilities/x_utilities.x b/pkg/utilities/x_utilities.x new file mode 100644 index 00000000..15a7fcc9 --- /dev/null +++ b/pkg/utilities/x_utilities.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Process definition of the UTILITIES package. + +task ucase = t_ucase, + lcase = t_lcase, + translit = t_translit, + detab = t_detab, + entab = t_entab, + urand = t_urand, + polyfit = t_polyfit, + curfit = t_curfit, + split = t_split, + surfit = t_surfit -- cgit